home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / pcfig4th.zip / 4TH-MAIN.ASM < prev    next >
Assembly Source File  |  1983-08-04  |  50KB  |  2,496 lines

  1. TITLE Forth Interest Group  8086 FORTH
  2. NAME FORTH
  3. PAGE 62,132
  4. .SALL
  5. .XCREF
  6.  
  7. COMMENT \
  8.         Forth Interest Group  8086 FORTH 
  9.  
  10.         Version 1.0
  11.  
  12.         Original implementation by Thomas Newman
  13.         made available by the
  14.             FORTH INTEREST GROUP
  15.             P.O. Box 1105
  16.             San Carlos, CA  94070
  17.  
  18.         Modified by
  19.             Joe Smith
  20.             U. of Penn./Dept. of Chemistry
  21.             34th & Spruce St.
  22.             Philadelphia, PA  19104
  23.             215 898-4797
  24.  
  25.         Available through
  26.             SIG/86
  27.             c/o Joseph Boykin
  28.             47-4 Sheridan Drive
  29.             Shrewsbury, MA  01545
  30.             617 845-1074
  31.  
  32.         Latest revision: June, 1983
  33.  
  34. This is a revision of fig-FORTH which includes the following changes:
  35.  
  36.     Source compatible with Microsoft's 8086 Macro Assembler
  37.  
  38.     Macros for dictionary headers
  39.  
  40.     Complete interface to MS-DOS, including screen files
  41.  
  42.     Command line arguments are interpreted
  43.  
  44.     All i/o is redirectable through execution vectors
  45.  
  46. \
  47. SUBTTL Assembly switches (TRUE/FALSE) and EQUATES
  48. PAGE
  49.  
  50.  
  51. INCLUDE    4TH-OPTS.H        ;assembly options
  52.  
  53. ; Version number:
  54.  
  55. FIGREL        EQU    1    ;fig release number
  56. FIGREV        EQU    0    ;fig revision number
  57. USRVER        EQU    0    ;user version number,0-25,printed as A-Z
  58.  
  59. ; Memory allocation parameters:
  60.  
  61. EM        EQU    0000        ;64K top of memory + 1
  62. NSCR        EQU    8        ;No. of 1K block buffers
  63. BUFSIZE        EQU    1024        ;size of FORTH's disk buffers
  64. US        EQU    80        ;User area size ( in bytes )
  65. RTS        EQU    160        ;Return stack/TIB size
  66.  
  67. BUF1        EQU    EM-(NSCR*(BUFSIZE+4))    ;first buffer addr.
  68. INITR0        EQU    BUF1-US        ;Start of return stack (R0)
  69. INITS0        EQU    INITR0-RTS    ;Start of param. stack (S0)
  70.  
  71. ; ASCII characters used
  72.  
  73. ANUL        EQU    0        ;ASCII NUL
  74. BELL        EQU    7        ;ASCII bell: ^G
  75. BSOUT        EQU    8        ;output backspace: ^H
  76. LF        EQU    10        ;ASCII linefeed
  77. FF        EQU    12        ;ASCII form feed
  78. ACR        EQU    13        ;ASCII carriage return
  79. BSIN        EQU    127        ;input delete char: DEL
  80.  
  81. SUBTTL Main entry points and COLD start data
  82. PAGE +
  83.  
  84.  
  85. INCLUDE    4TH-LIB.MAC        ;Required support macros
  86.  
  87. ; Note: FORTH only uses one segment, and runs as a .COM program
  88.  
  89. MAIN        SEGMENT
  90.         ASSUME    CS:MAIN,DS:MAIN,SS:MAIN,ES:MAIN
  91.  
  92.         ORG    100H
  93.  
  94. ORIG:         NOP
  95.         JMP    CLD        ;vector to COLD start
  96.         NOP
  97.         JMP    WRM        ;vector to WARM start
  98.  
  99.  
  100.         DB    FIGREL        ;version # printed by COLD
  101.         DB    FIGREV
  102.         DB    USRVER
  103.         DB    0EH        ;version attributes
  104.         DW    LASTNFA        ;top word in FORTH vocabulary
  105.         DW    BSIN        ;backspace recognised by EXPECT
  106.         DW    INITR0        ;initial UP
  107.  
  108. ; COLD start moves the following to USER var's. 3-10
  109. ; MUST BE IN SAME ORDER AS USER VARIABLES
  110.  
  111.         DW    INITS0        ;  S0
  112.         DW    INITR0        ;  R0
  113.         DW    INITS0        ;  TIB
  114.         DW    32        ;  WIDTH
  115.         DW    0        ;  WARNING
  116.         DW    INITDP        ;  FENCE
  117.         DW    INITDP        ;  DP
  118.         DW    FORTH+6        ;  VOC-LINK
  119.  
  120. ; CPU id printed by COLD
  121.  
  122.     IF    _ALIGN
  123.         DD    0B3260005H    ;"8086" ( in base 36 ! )
  124.     ELSE
  125.         DD    0B3280005H    ;"8088" ( in base 36 ! )
  126.     ENDIF
  127.  
  128. UP         DW    INITR0        ;user area pointer
  129. RPP         DW    INITR0        ;return stack pointer
  130.  
  131.     $REPORT    <Boot parameters completed>
  132.     $REPORT    <LIMIT    =>,%EM
  133.     $REPORT    <FIRST    =>,%BUF1
  134.     $REPORT    <R0    =>,%INITR0
  135.     $REPORT    <S0    =>,%INITS0
  136.  
  137. SUBTTL FORTH register usage
  138. PAGE +
  139.  
  140.  
  141. COMMENT \
  142.  
  143. FORTH    8086    Preservation rules
  144. ------------------------------------------------------------------------
  145. IP    SI    Interpreter pointer
  146.         Must be preserved across words
  147.         NOTE: Also preserve the direction flag (always UP)!
  148.  
  149. W    DX    Working register
  150.         Jump to label DPUSH will push contents onto
  151.         the parameter stack before falling into APUSH
  152.  
  153. SP    SP    Parameter stack pointer
  154.         Must be preserved across words
  155.  
  156. RP    BP    Return stack pointer
  157.         Must be preserved across words
  158.  
  159.     AX    General purpose register
  160.         Jump to label APUSH pushes contents onto
  161.         the parameter stack
  162.  
  163.     CS,DS,SS
  164.         Must be preserved across words
  165.  
  166.         All other registers are available
  167.  
  168. \
  169. SUBTTL Comment conventions
  170. PAGE
  171.  
  172.  
  173. COMMENT \
  174.  
  175. ==    means    is equal to
  176. :=    means    is assigned the value
  177.  
  178. name    ==    address of name
  179. (name)    ==    contents at address name
  180. ((name))==    contents at address contained in name
  181.  
  182. NFA    ==    Name Field Address
  183. LFA    ==    Link Field Address
  184. CFA    ==    Code Field Address
  185. PFA    ==    Parameter Field Address
  186.  
  187. S1,S2    ==    parameter stack: top item, next item
  188. R1,R2    ==    return stack: top word, next word
  189.  
  190. LSB    ==    Least Significant Bit
  191. MSB    ==    Most Significant Bit
  192. LB,LW    ==    Low Byte, Low Word
  193. HB,HW    ==    High Byte, High Word
  194. \
  195.  
  196.     IF    _DEBUG
  197. SUBTTL Debugging support
  198. PAGE +
  199.  
  200. BIP         DW    0    ;breakpoint start address
  201. BIPE         DW    0    ;breakpoint end address
  202.  
  203. COMMENT \
  204.  
  205. BIP    BIPE    effect
  206. -----    -----    -------------------------------------------
  207. 0    ?    trace off
  208. -1    ?    trace all NEXT calls
  209. addr1    0    trace addr1 only
  210. addr1    addr2    trace NEXT calls between addr1 and addr2
  211.  
  212. NOTE: addr1/addr2 can't be CFA's
  213. \
  214.  
  215. ; NEXT with code to trace FORTH word execution
  216.  
  217. TNEXT:         PUSHF        ;save executing word's data
  218.         PUSH    AX
  219.         MOV    AX,BIP    ;addr1
  220.         OR    AX,AX
  221.         JZ    TNEXT2    ;no trace if addr1==0
  222.         CMP    AX,-1
  223.         JZ    TNEXT1    ;trace all
  224.         CMP    AX,SI
  225.         JZ    TNEXT1    ;in range, so trace
  226.         JA    TNEXT2    ;not in range
  227.         MOV    AX,BIPE
  228.         OR    AX,AX
  229.         JZ    TNEXT2    ;trace addr1 only
  230.         CMP    AX,SI
  231.         JB    TNEXT2    ;no longer in range
  232.  
  233. ; Pause on address
  234.  
  235. TNEXT1:     POP    AX    ;restore executing word's reg's.
  236.         POPF
  237.         INT    3    ;Break to DEBUG
  238. BREAK:         JMP    SHORT TNEXT3    ;continue
  239.  
  240. ; No pause, restore registers
  241.  
  242. TNEXT2:     POP    AX
  243.         POPF
  244. TNEXT3:     LODSW        ;AX:=(IP)
  245.         MOV    BX,AX
  246.         JMP    SHORT NEXT1
  247.  
  248.     $REPORT    <Debug trace included>
  249.     ENDIF
  250. SUBTTL Inner interpreter, DPUSH, APUSH entry points
  251. PAGE +
  252.  
  253.  
  254. DPUSH:         PUSH    DX    ;common entry point; DX, AX to S2, S1
  255. APUSH:         PUSH    AX    ;common entry point, AX to S1
  256.  
  257. NEXT:
  258.     IF    _DEBUG
  259.         JMP    TNEXT
  260.     ELSE
  261.         LODSW            ; AX:=(IP), IP:=IP+1
  262.         MOV    BX,AX
  263.     ENDIF
  264.  
  265. NEXT1:         MOV    DX,BX
  266.         INC    DX        ; W:=(IP)+1
  267.         JMP    WORD PTR [BX]    ;to CFA
  268. SUBTTL FORTH dictionary 
  269. PAGE +
  270.  
  271.  
  272. ;=C   LIT    push an inline literal            -- n
  273.  
  274.         $CODE    83H,LI,T,LIT
  275.         LODSW
  276.         JMP    APUSH
  277.  
  278. ;=C   EXECUTE    executes the word at CFA        CFA -- ?
  279.  
  280.         $CODE    87H,EXECUT,E,EXEC
  281.         POP    BX
  282.         JMP    NEXT1
  283.  
  284. ;=C   BRANCH    adds an inline offset to IP        --
  285.  
  286.         $CODE    86H,BRANC,H,BRAN
  287. BRAN1:        ADD    SI,[SI]        ; IP:=IP+(IP)
  288.         JMP    NEXT
  289.  
  290. ;=C   0BRANCH    branch if f is zero            f --
  291.  
  292.         $CODE    87H,0BRANC,H,ZBRAN
  293.         POP    AX
  294.         OR    AX,AX
  295.         JZ    BRAN1        ;f==0, so branch
  296.         INC    SI        ;point IP to next word
  297.         INC    SI
  298.         JMP    NEXT
  299.  
  300. ;=C   (LOOP)    execution time loop code        --
  301.  
  302.         $CODE    86H,(LOOP,),XLOOP
  303.         MOV    BX,1
  304. XLOO1:         ADD    [BP],BX        ;R1:=R1+1
  305.         MOV    AX,[BP]
  306.         SUB    AX,2[BP]    ;compare new index to limit
  307.         XOR    AX,BX
  308.         JS    BRAN1        ;branch - keep looping
  309.  
  310.         ADD    BP,4        ;end of loop, drop R1, R2
  311.         INC    SI        ;skip branch offset
  312.         INC    SI
  313.         JMP    NEXT
  314.  
  315. ;=C   (+LOOP)    (LOOP) with increment on S1        n --
  316.  
  317.         $CODE    87H,(+LOOP,),XPLOO
  318.         POP    BX
  319.         JMP    XLOO1
  320.  
  321. ;=C   (DO)    run-time loop initialization        n2 n1 --
  322.  
  323.         $CODE    84H,(DO,),XDO
  324.         POP    DX        ;index
  325.         POP    AX        ;limit
  326.         XCHG    BP,SP        ;put them on the return stack
  327.         PUSH    AX        ;R2:=S2
  328.         PUSH    DX        ;R1:=S2
  329.         XCHG    BP,SP
  330.         JMP    NEXT
  331.  
  332. ;=C   I        leave index value            -- n
  333.  
  334.         $CODE    81H,,I,IDO
  335.         MOV    AX,[BP]        ;AX:=R1 (index)
  336.         JMP    APUSH
  337.  
  338. ;=C   DIGIT    convert c to binary using base n1    c n1 -- [n2] f
  339.  
  340.         $CODE    85H,DIGI,T,DIGIT
  341.         POP    DX        ;base
  342.         POP    AX        ;ASCII char
  343.         SUB    AL,'0'
  344.         JB    DIGI2        ;error if c < '0'
  345.         CMP    AL,9
  346.         JBE    DIGI1        ;number 0-9
  347.         SUB    AL,7
  348.         CMP    AL,10        ;number A-Z?
  349.         JB    DIGI2        ;no, error
  350. DIGI1:         CMP    AL,DL
  351.         JAE    DIGI2        ;error if digit > base
  352.         SUB    DX,DX
  353.         MOV    DL,AL        ;new binary number
  354.         MOV    AL,1        ;f==TRUE if OK
  355.         JMP    DPUSH
  356. DIGI2:         SUB    AX,AX
  357.         JMP    APUSH        ;f==FALSE if error
  358.  
  359. PAGE
  360.  
  361.  
  362. ;=C*  (FIND)    dictionary search primtive        a1 NFA -- [PFA b] f
  363.  
  364.         $CODE    86H,(FIND,),PFIND
  365.         MOV    AX,DS
  366.         MOV    ES,AX        ;DI defaults to ES
  367.         POP    BX        ;BX:=NFA
  368.         POP    CX        ;CX:=a1 ( search string )
  369.  
  370. PFIN1:         MOV    DI,CX        ;get addr
  371.         MOV    AL,[BX]        ;get word length
  372.         MOV    DL,AL
  373.         XOR    AL,[DI]
  374.         AND    AL,3FH        ;check lengths+smudge bit
  375.         JNZ    PFIN5        ;lengths differ
  376.  
  377. PFIN2:         INC    BX        ;length matches, check chars
  378.         INC    DI
  379.         MOV    AL,[BX]
  380.         XOR    AL,[DI]
  381.         ADD    AL,AL        ;this checks bit 8
  382.         JNZ    PFIN5        ;chars differ
  383.         JNB    PFIN2        ;OK so far
  384.  
  385.     IF    _ALIGN
  386.         ADD    BX,6        ;Compute PFA ( could be 5 or 6)
  387.         AND    BX,0FFFEH    ;Clear LSB to align
  388.     ELSE
  389.         ADD    BX,5
  390.     ENDIF
  391.         ;end of word (bit 8 set), a match
  392.  
  393.         PUSH    BX        ;S3:=PFA
  394.         MOV    AX,1        ;f:=TRUE
  395.         SUB    DH,DH        ;DX:=length byte
  396.         JMP    DPUSH        ;S2:=f, S1:=l
  397.  
  398.         ; No match, try the next dictionary entry
  399.  
  400. PFIN5:         INC    BX        ;advance BX to LFA
  401.         JB    PFIN6        ;bit 8 set - must be the end
  402.         MOV    AL,[BX]
  403.         ADD    AL,AL
  404.         JMP    PFIN5
  405. PFIN6:
  406.  
  407.     IF    _ALIGN
  408.         INC    BX        ;This could be one too many...
  409.         AND    BX,0FFFEH    ;Clear LSB to align
  410.     ENDIF
  411.  
  412.         MOV    BX,[BX]        ;BX:=(LFA)
  413.         OR    BX,BX        ;start of dictionary?
  414.         JNZ    PFIN1        ;no, keep looking
  415.         MOV    AX,0        ;no match, f:=FALSE
  416.         JMP    APUSH        ;S1:=f
  417.  
  418. PAGE
  419.  
  420.  
  421. ;=C   ENCLOSE    text scanning primitive            a1 c -- a1 n1 n2 n3
  422.  
  423.         $CODE    87H,ENCLOS,E,ENCL
  424.         POP    AX        ;delimiter c
  425.         POP    BX        ;text addr
  426.         PUSH    BX        ;S4:=text addr
  427.         MOV    AH,0
  428.         MOV    DX,-1        ;DX is counter
  429.         DEC    BX        ;BX points to text
  430.  
  431.         ; Scan to first non-delimiter
  432.  
  433. ENCL1:         INC    BX        ;next char
  434.         INC    DX        ;count it
  435.         CMP    AL,[BX]        ;delimiter found?
  436.         JZ    ENCL1        ;not yet, keep looking
  437.         PUSH    DX        ;yes, S3:=count
  438.         CMP    AH,[BX]        ;found NUL char?
  439.         JNZ    ENCL2        ;no...
  440.         MOV    AX,DX        ;yes, n2:=n3
  441.         INC    DX        ;n3:=n3+1
  442.         JMP    DPUSH        ;exit
  443.  
  444.         ; Enclose text to first delimiter
  445.  
  446. ENCL2:         INC    BX
  447.         INC    DX
  448.         CMP    AL,[BX]
  449.         JZ    ENCL4        ;found it...
  450.         CMP    AH,[BX]        ;NUL?
  451.         JNZ    ENCL2        ;no, keep looking
  452.  
  453.         ; Found NUL at end of text
  454.  
  455. ENCL3:         MOV    AX,DX
  456.         JMP    DPUSH
  457.  
  458.         ; Found delimiter
  459.  
  460. ENCL4:         MOV    AX,DX        ;count to delimiter
  461.         INC    AX        ;count to first > delimiter
  462.         JMP    DPUSH        ;S2, S1
  463.  
  464. SUBTTL Input/output primitives
  465. PAGE
  466.  
  467.  
  468. ;=:*  EMIT    char output                c --
  469.  
  470.         $COLON    84H,EMI,T,EMIT
  471.         DW    TICKEMIT,    AT,    EXEC
  472.         DW    ONE,OUTT
  473.         DW    PSTOR,SEMIS
  474.  
  475. ;=:*  KEY    char input                -- c
  476.  
  477.         $COLON    83H,KE,Y,KEY
  478.         DW    TICKEY,    AT,    EXEC,    SEMIS
  479.  
  480. ;=C   ?TERMINAL    console status                -- f
  481.  
  482.         $CODE    89H,?TERMINA,L,QTERM
  483.         JMP    PQTER
  484.  
  485. ;=:*  CR    output carriage return/line feed    --
  486.  
  487.         $COLON 82H,C,R,CR
  488.         DW    TICKCR,    AT,    EXEC,    SEMIS
  489.  
  490. SUBTTL
  491. PAGE
  492.  
  493.  
  494. ;=C   CMOVE    byte block move                a1 a2 n --
  495.  
  496.         $CODE    85H,CMOV,E,CMOVE
  497.         CLD            ;count up
  498.         MOV    BX,SI        ;save IP
  499.         POP    CX        ;move count
  500.         POP    DI        ;a2 ( destination )
  501.         POP    SI        ;a1 ( source )
  502.         MOV    AX,DS
  503.         MOV    ES,AX        ;intrasegment only
  504.     REP    MOVSB            ;all that for this?
  505.         MOV    SI,BX
  506.         JMP    NEXT
  507.  
  508. ;=C   U*    unsigned mixed multiply            u1 u2 -- ud
  509.  
  510.         $CODE    82H,U,*,USTAR
  511.         POP    AX
  512.         POP    BX
  513.         MUL    BX
  514.         XCHG    AX,DX        ;S1:=MSW, S2:=LSW
  515.         JMP    DPUSH
  516.  
  517. ;=C   U/    unsigned mixed divide            ud u -- urem uquot
  518.  
  519.         $CODE    82H,U,/,USLAS
  520.         POP    BX        ;BX:=divisor
  521.         POP    DX        ;DX:=MSW of dividend
  522.         POP    AX        ;AX:=LSW
  523.         CMP    DX,BX        ;0?
  524.         JNB    DZERO
  525.         DIV    BX
  526.         JMP    DPUSH
  527. DZERO:         MOV    AX,-1        ;divide by zero! leave -1
  528.         MOV    DX,AX
  529.         JMP    DPUSH
  530.  
  531. ;=C   AND    bitwise AND                n n -- n
  532.  
  533.         $CODE    83H,AN,D,ANDD
  534.         POP    AX
  535.         POP    BX
  536.         AND    AX,BX
  537.         JMP    APUSH
  538.  
  539. ;=C   OR    bitwise OR                n n -- n
  540.  
  541.         $CODE    82H,O,R,ORR
  542.         POP    AX
  543.         POP    BX
  544.         OR    AX,BX
  545.         JMP    APUSH
  546.  
  547. ;=C   XOR    bitwise exclusive OR            n n -- n
  548.  
  549.         $CODE    83H,XO,R,XORR
  550.         POP    AX
  551.         POP    BX
  552.         XOR    AX,BX
  553.         JMP    APUSH
  554.  
  555. ;=C   SP@    push current parameter stack pointer    -- SP
  556.  
  557.         $CODE    83H,SP,@,SPAT
  558.         MOV    AX,SP
  559.         JMP    APUSH
  560.  
  561. ;=C   SP!    reset parameter stack            ? --
  562.  
  563.         $CODE    83H,SP,!!!!,SPSTO
  564.         MOV    BX,UP        ;USER variable base addr
  565.         MOV    SP,6[BX]    ;S0 is 6 bytes above base
  566.         JMP    NEXT
  567.  
  568. ;=C   RP@    push current RP onto parameter stack    -- RP
  569.  
  570.         $CODE    83H,RP,@,RPAT
  571.         MOV    AX,BP
  572.         JMP    APUSH
  573.  
  574. ;=C   RP!    reset return stack            ? --
  575.  
  576.         $CODE    83H,RP,!!!!,RPSTO
  577.         MOV    BX,UP        ;USER variable base addr
  578.         MOV    BP,8[BX]    ;offset of R0 is 8
  579.         JMP    NEXT
  580.  
  581. ;=C   ;S    end of screen or run time colon word    --
  582.  
  583.         $CODE    82H,!!!;,S,SEMIS
  584.         MOV    SI,[BP]        ;IP:=R1 - pop return stack
  585.         INC    BP        ;adjust RP
  586.         INC    BP
  587.         JMP    NEXT
  588.  
  589. ;=C   LEAVE    force loop exit                --
  590.  
  591.         $CODE    85H,LEAV,E,LEAVE
  592.         MOV    AX,[BP]
  593.         MOV    2[BP],AX    ;limit:=index
  594.         JMP    NEXT
  595.  
  596. ;=C   >R    push parm. stack to return stack    n --
  597.  
  598.         _NFA    = $
  599.         DB    82H,'>','R'+80H        ;macro can't handle it!
  600.         $LINKS    $+2,TOR
  601.  
  602.         POP    BX        ;BX:=S1
  603.         DEC    BP        ;adjust RP
  604.         DEC    BP
  605.         MOV    [BP],BX        ;push it
  606.         JMP    NEXT
  607.  
  608. ;=C   R>    pop return stack to parm. stack        -- n
  609.  
  610.         $CODE    82H,R,!!!>,FROMR
  611.         MOV    AX,[BP]        ;AX:=R1
  612.         INC    BP        ;adjust RP
  613.         INC    BP
  614.         JMP    APUSH
  615.  
  616. ;=C   R        top of return stack to parm. stack    -- n
  617.  
  618.         $NAME    81H,,R
  619.         $LINKS    IDO+2,RR    ;synonym for I
  620.  
  621. ;=C   0=    test top of stack for zero        n -- f
  622.  
  623.         $CODE    82H,0,=,ZEQU
  624.         POP    AX
  625.         OR    AX,AX
  626.         MOV    AX,1
  627.         JZ    ZEQU1
  628.         DEC    AX
  629. ZEQU1:        JMP    APUSH
  630.  
  631. ;=C   0<    test top of stack for negative value    n -- f
  632.  
  633.         $CODE    82H,0,!!!<,ZLESS
  634.         POP    AX
  635.         OR    AX,AX
  636.         MOV    AX,1
  637.         JS    ZLESS1
  638.         DEC    AX
  639. ZLESS1:        JMP    APUSH
  640.  
  641. ;=C   +        16-bit addition                n1 n2 -- nsum
  642.  
  643.         $CODE    81H,,+,PLUS
  644.         POP    AX
  645.         POP    BX
  646.         ADD    AX,BX
  647.         JMP    APUSH
  648.  
  649. ;=C   D+    32-bit addition                d1 d2 -- dsum
  650.  
  651.         $CODE    82H,D,+,DPLUS
  652.         POP    AX        ;AX:=d2 MSW
  653.         POP    DX        ;DX:=d2 LSW
  654.         POP    BX        ;BX:=d1 MSW
  655.         POP    CX        ;CX:=d1 LSW
  656.         ADD    DX,CX        ;add low words
  657.         ADC    AX,BX        ;add high words with carry
  658.         JMP    DPUSH
  659.  
  660. ;=C   MINUS    16-bit two's complement            n -- -n
  661.  
  662.         $CODE    85H,MINU,S,MINUS
  663.         POP    AX
  664.         NEG    AX
  665.         JMP    APUSH
  666.  
  667. ;=C   DMINUS    32-bit two's complement            d -- -d
  668.  
  669.         $CODE    86H,DMINU,S,DMINU
  670.         POP    BX        ;MSW
  671.         POP    CX        ;LSW
  672.         SUB    AX,AX
  673.         MOV    DX,AX
  674.         SUB    DX,CX        ;subtract from 0
  675.         SBB    AX,BX        ;again for high word
  676.         JMP    DPUSH
  677.  
  678. ;=C   OVER    copy second stack item to top        n1 n2 -- n1 n2 n1
  679.  
  680.         $CODE    84H,OVE,R,OVER
  681.         POP    DX
  682.         POP    AX
  683.         PUSH    AX
  684.         JMP    DPUSH
  685.  
  686. ;=C   DROP    throw out top stack item        n --
  687.  
  688.         $CODE    84H,DRO,P,DROP
  689.         POP    AX
  690.         JMP    NEXT
  691.  
  692. ;=C   SWAP    exchange top two stack items        n1 n2 -- n2 n1
  693.  
  694.         $CODE    84H,SWA,P,SWAP
  695.         POP    DX
  696.         POP    AX
  697.         JMP    DPUSH
  698.  
  699. ;=C   DUP    duplicate the top stack item        n -- n n
  700.  
  701.         $CODE    83H,DU,P,DUPP
  702.         POP    AX
  703.         PUSH    AX
  704.         JMP    APUSH
  705.  
  706. ;=C   2DUP    duplicate the top two stack items    n1 n2 -- n1 n2 n1 n2
  707.  
  708.         $CODE    84H,2DU,P,TDUP
  709.         POP    AX
  710.         POP    DX
  711.         PUSH    DX
  712.         PUSH    AX
  713.         JMP    DPUSH
  714.  
  715. ;=C   +!    add to a memory location        n addr --
  716.  
  717.         $CODE    82H,+,!!!!,PSTOR
  718.         POP    BX
  719.         POP    AX
  720.         ADD    [BX],AX
  721.         JMP    NEXT
  722.  
  723. ;=C   TOGGLE    toggle bits at a memory location    n addr --
  724.  
  725.         $CODE    86H,TOGGL,E,TOGGL
  726.         POP    AX
  727.         POP    BX
  728.         XOR    [BX],AL
  729.         JMP    NEXT
  730.  
  731. ;=C   @        push memory location to stack        addr -- n
  732.  
  733.         $CODE    81H,,@,AT
  734.         POP    BX
  735.         MOV    AX,[BX]
  736.         JMP    APUSH
  737.  
  738. ;=C   C@    push byte location to stack        addr -- b
  739.  
  740.         $CODE    82H,C,@,CAT
  741.         POP    BX
  742.         MOV    AL,[BX]
  743.         SUB    AH,AH
  744.         JMP    APUSH
  745.  
  746. ;=C   2@    fetch 32-bit number            addr -- d
  747.  
  748.         $CODE    82H,2,@,TAT
  749.         POP    BX
  750.         MOV    AX,[BX]        ;LSW at addr
  751.         MOV    DX,[BX+2]    ;MSW at addr+2
  752.         JMP    DPUSH
  753.  
  754. ;=C   !        pop stack to memory - "store"        n addr --
  755.  
  756.         $CODE    81H,,!!!!,STORE
  757.         POP    BX
  758.         POP    AX
  759.         MOV    [BX],AX
  760.         JMP    NEXT
  761.  
  762. ;=C   C!    byte store - "see-store"        b addr --
  763.  
  764.         $CODE    82H,C,!!!!,CSTOR
  765.         POP    BX
  766.         POP    AX
  767.         MOV    [BX],AL
  768.         JMP    NEXT
  769.  
  770. ;=C   2!    32-bit store                d addr --
  771.  
  772.         $CODE    82H,2,!!!!,TSTOR
  773.         POP    BX
  774.         POP    AX
  775.         MOV    [BX],AX        ;move LSW to addr
  776.         POP    AX
  777.         MOV    2[BX],AX    ;move MSW to addr+2
  778.         JMP    NEXT
  779. SUBTTL Defining words
  780. PAGE
  781.  
  782.  
  783. ;=C   :        begin colon definition            --
  784.  
  785.         $COLON    0C1H,,:
  786.         DW    QEXEC,    SCSP    ;compile time code
  787.         DW    CURR,    AT
  788.         DW    CONT,    STORE
  789.         DW    CREAT,    RBRAC
  790.         DW    PSCOD
  791.                     ;run time code
  792. DOCOL:         INC    DX        ;W:=W+1
  793.         DEC    BP
  794.         DEC    BP        ;RP:=RP-2
  795.         MOV    [BP],SI        ;push IP onto return stack
  796.         MOV    SI,DX        ;IP:=W
  797.         JMP    NEXT
  798.  
  799. ;=:   ;        end colon definition            --
  800.  
  801.         $COLON    0C1H,,!!!;
  802.         DW    QCSP,    COMP
  803.         DW    SEMIS,    SMUDG
  804.         DW    LBRAC,    SEMIS
  805.  
  806. ;=:   NOOP    do nothing - no operation        --
  807.  
  808.         $COLON    84H,NOO,P,NOOP
  809.         DW    SEMIS
  810.  
  811. ;=:   CONSTANT    define a symbolic constant        n --
  812.  
  813.         $COLON    88H,CONSTAN,T,CON
  814.         DW    CREAT,    SMUDG    ;compile time code
  815.         DW    COMMA,    PSCOD
  816.                     ;run time code
  817. DOCON:         INC    DX        ;point W to PFA
  818.         MOV    BX,DX
  819.         MOV    AX,[BX]        ;get data at PFA
  820.         JMP    APUSH        ;here it is!
  821.  
  822. ;=:   VARIABLE    define a symbolic variable        n --
  823.  
  824.         $COLON    88H,VARIABL,E
  825.         DW    CON,    PSCOD    ;compile time code
  826.                     ;run time code
  827. DOVAR:         INC    DX        ;point W to PFA
  828.         PUSH    DX        ;return PFA
  829.         JMP    NEXT
  830.  
  831. ;=:   USER    define a user variable            n --
  832.  
  833.         $COLON    84H,USE,R
  834.         DW    CON,    PSCOD    ;compile time code
  835.                     ;run time code
  836. DOUSE:         INC    DX        ;point W to PFA
  837.         MOV    BX,DX        ;BX:=(PFA)   offset
  838.         MOV    BL,[BX]        ;BX:=(PFA)  offset<256
  839.         SUB    BH,BH        ;just to be safe...
  840.         MOV    DI,UP        ;DI:=UP  (user area base addr)
  841.         LEA    AX,[BX+DI]    ;load effective address
  842.         JMP    APUSH        ;push address to stack
  843.  
  844.     $REPORT    <Code-level kernel completed>
  845.  
  846. SUBTTL Constants and USER variables
  847. PAGE +
  848.  
  849.  
  850. ;=#   0        zero                    -- 0
  851.  
  852.         $CONST    81H,,0,ZERO
  853.         DW    0
  854.  
  855. ;=#   1        one                    -- 1
  856.  
  857.         $CONST    81H,,1,ONE
  858.         DW    1
  859.  
  860. ;=#   2        two                    -- 2
  861.  
  862.         $CONST    81H,,2,TWO
  863.         DW    2
  864.  
  865. ;=#   3        three                    -- 3
  866.  
  867.         $CONST    81H,,3,THREE
  868.         DW    3
  869.  
  870. ;=#   BL    ASCII blank                -- 32
  871.  
  872.         $CONST    82H,B,L,BLS
  873.         DW    20H
  874.  
  875. ;=#   C/L    characters per line            -- 64
  876.  
  877.         $CONST    83H,C/,L,CSLL
  878.         DW    64
  879.  
  880. ;=#   FIRST    address of lowest disk buffer        -- addr
  881.  
  882.         $CONST    85H,FIRS,T,FIRST
  883.         DW    BUF1
  884.  
  885. ;=#   LIMIT    last available memory address + 1    -- addr
  886.  
  887.         $CONST    85H,LIMI,T,LIMIT
  888.         DW    EM
  889.  
  890. ;=#   B/BUF    size of disk buffers in bytes        -- 1024
  891.  
  892.         $CONST    85H,B/BU,F,BBUF
  893.         DW    BUFSIZE
  894.  
  895. ;=#   B/SCR    number of disk buffers per screen    -- 1
  896.  
  897.         $CONST    85H,B/SC,R,BSCR
  898.         DW    1
  899. SUBTTL
  900. PAGE +
  901.  
  902.  
  903. ;=:   +ORIGIN    word for accessing data in low memory    n -- addr
  904.  
  905.         $COLON    87H,+ORIGI,N,PORIG
  906.         DW    LIT,    ORIG
  907.         DW    PLUS,    SEMIS
  908.  
  909. SUBTTL USER variables
  910. PAGE +
  911.  
  912.  
  913. ;=U   S0    parameter stack base            -- addr
  914.  
  915.         $USER    82H,S,0,SZERO
  916.         DW    6        ;offset in user area
  917.  
  918. ;=U   R0    return stack base            -- addr
  919.  
  920.         $USER    82H,R,0,RZERO
  921.         DW    8
  922.  
  923. ;=U   TIB    Terminal Input Buffer address        -- addr
  924.  
  925.         $USER    83H,TI,B,TIB
  926.         DW    10
  927.  
  928. ;=U   WIDTH    maximum length of word names        -- addr
  929.  
  930.         $USER    85H,WIDT,H,NWIDTH
  931.         DW    12
  932.  
  933. ;=U   WARNING    switch for error processing: 0, 1, -1    -- addr
  934.  
  935.         $USER    87H,WARNIN,G,WARN
  936.         DW    14
  937.  
  938. ;=U   FENCE    pointer to protected dictionary        -- addr
  939.  
  940.         $USER    85H,FENC,E,FENCE
  941.         DW    16
  942.  
  943. ;=U   DP    top address used in dictionary        -- addr
  944.  
  945.         $USER    82H,D,P,DP
  946.         DW    18
  947.  
  948. ;=U   VOC-LINK    pointer to top vocabulary        -- addr
  949.  
  950.         $USER    88H,VOC-LIN,K,VOCL
  951.         DW    20
  952.  
  953. ;The following user variables hold CFA's for their
  954. ;respective logical functions
  955.  
  956.  
  957. ;=U+  @KEY    CFA of function to do character input    -- addr
  958.  
  959.         $USER    84H,@KE,Y,TICKEY
  960.         DW    22
  961.  
  962. ;=U+  @EMIT    CFA of function to do character output    -- addr
  963.  
  964.         $USER    85H,@EMI,T,TICKEMIT
  965.         DW    24
  966.  
  967. ;=U+  @CR    CFA of function to output newline    -- addr
  968.  
  969.         $USER    83H,@C,R,TICKCR
  970.         DW    58
  971.  
  972. ;=U+  @BLKRD    CFA of function to read one block    -- addr
  973.  
  974.         $USER    86H,@BLKR,D,TICKBRD
  975.         DW    26
  976.  
  977. ;=U+  @BLKWRT    CFA of function to write one block    -- addr
  978.  
  979.         $USER    87H,@BLKWR,T,TICKBWRT
  980.         DW    28
  981.  
  982. ;=U   BLK    current block, 0 if terminal        -- addr
  983.  
  984.         $USER    83H,BL,K,BLK
  985.         DW    30
  986.  
  987. ;=U   IN    current character in input stream    -- addr
  988.  
  989.         $USER    82H,I,N,INN
  990.         DW    32
  991.  
  992. ;=U   OUT    count of characters output        -- addr
  993.  
  994.         $USER    83H,OU,T,OUTT
  995.         DW    34
  996.  
  997. ;=U   SCR    current screen                -- addr
  998.  
  999.         $USER    83H,SC,R,SCR
  1000.         DW    36
  1001.  
  1002. ;=U   OFFSET    number of lowest block to be used    -- addr
  1003.  
  1004.         $USER    86H,OFFSE,T,OFSET
  1005.         DW    38
  1006.  
  1007. ;=U   CONTEXT    current vocabulary for execution    -- addr
  1008.  
  1009.         $USER    87H,CONTEX,T,CONT
  1010.         DW    40
  1011.  
  1012. ;=U   CURRENT    current vocabulary for definitions    -- addr
  1013.  
  1014.         $USER    87H,CURREN,T,CURR
  1015.         DW    42
  1016.  
  1017. ;=U   STATE    current interpreter state        -- addr
  1018.  
  1019.         $USER    85H,STAT,E,STATE
  1020.         DW    44
  1021.  
  1022. ;=U   BASE    current number base for i/o        -- addr
  1023.  
  1024.         $USER    84H,BAS,E,BASE
  1025.         DW    46
  1026.  
  1027. ;=U   DPL    Decimal Point Locator             -- addr
  1028.  
  1029.         $USER    83H,DP,L,DPL
  1030.         DW    48
  1031.  
  1032. ;=U   CSP    temporary storage for Current SP    -- addr
  1033.  
  1034.         $USER    83H,CS,P,CSPP
  1035.         DW    52
  1036.  
  1037. ;=U   R#    current editing cursor location        -- addr
  1038.  
  1039.         $USER    82H,R,#,RNUM
  1040.         DW    54
  1041.  
  1042. ;=U   HLD    text pointer used in number formatting    -- addr
  1043.  
  1044.         $USER    83H,HL,D,HLD
  1045.         DW    56
  1046.  
  1047.     $REPORT    <Constants and user variables completed>
  1048.  
  1049. SUBTTL FORTH definitions
  1050. PAGE +
  1051.  
  1052.  
  1053. ;=C   1+    increment the top stack item        n -- n+1
  1054.  
  1055.         $CODE    82H,1,+,ONEP
  1056.         POP    AX
  1057.         INC    AX
  1058.         JMP    APUSH
  1059.  
  1060. ;=C   2+    add 2 to the top stack item        n -- n+2
  1061.  
  1062.         $CODE    82H,2,+,TWOP
  1063.         POP    AX
  1064.         INC    AX
  1065.         INC    AX
  1066.         JMP    APUSH
  1067.  
  1068. ;=C+  1-    decrement the top stack item        n -- n-1
  1069.  
  1070.         $CODE    82H,1,-,ONEM
  1071.         POP    AX
  1072.         DEC    AX
  1073.         JMP    APUSH
  1074.  
  1075. ;=C+  2-    subtract 2 from the top stack item    n -- n-2
  1076.  
  1077.         $CODE    82H,2,-,TWOM
  1078.         POP    AX
  1079.         DEC    AX
  1080.         DEC    AX
  1081.         JMP    APUSH
  1082.  
  1083. ;=:   HERE    next available dictionary location    -- addr
  1084.  
  1085.         $COLON    84H,HER,E,HERE
  1086.         DW    DP,    AT,    SEMIS
  1087.  
  1088. ;=:   ALLOT    reserve n bytes in the dictionary    n --
  1089.  
  1090.         $COLON    85H,ALLO,T,ALLOT
  1091.         DW    DP,    PSTOR,    SEMIS
  1092.  
  1093. ;=:   ,        compile n into the dictionary        n --
  1094.  
  1095.         $COLON    81H,,!!!,,COMMA
  1096.         DW    HERE,    STORE
  1097.         DW    TWO,    ALLOT,    SEMIS
  1098.  
  1099. ;=:   C,    compile a byte into the dictionary    b --
  1100.  
  1101.         $COLON    82H,C,!!!,,CCOMM
  1102.         DW    HERE,    CSTOR
  1103.         DW    ONE,    ALLOT,    SEMIS
  1104.  
  1105. ;=C   -        16-bit subtraction            n1 n2 -- n1-n2
  1106.  
  1107.         $CODE    81H,,-,SUBB
  1108.         POP    DX
  1109.         POP    AX
  1110.         SUB    AX,DX
  1111.         JMP    APUSH
  1112.  
  1113. ;=:   =        test top two items for equality        n1 n2 -- f
  1114.  
  1115.         $COLON    81H,,=,EQUAL
  1116.         DW    SUBB,    ZEQU,    SEMIS
  1117.  
  1118. ;=C   <        test for top number > second number    n1 n2 -- f
  1119.  
  1120.         $CODE    81H,,!!!<,LESS
  1121.         POP    DX
  1122.         POP    AX
  1123.         MOV    BX,DX
  1124.         XOR    BX,AX
  1125.         JS    LES1        ;signs different
  1126.         SUB    AX,DX
  1127. LES1:         OR    AX,AX        ;test sign bit
  1128.         MOV    AX,0        ;assume false
  1129.         JNS    LES2        ;not less than
  1130.         INC    AX        ;return true (1)
  1131. LES2:         JMP    APUSH
  1132.  
  1133. ;=:   U<    unsigned test for top > next item    u1 u2 -- f
  1134.  
  1135.         $COLON    82H,U,!!!<,ULESS
  1136.         DW    TDUP,    XORR,    ZLESS
  1137.             $GO?0    ULES1
  1138.         DW    DROP,    ZLESS,    ZEQU
  1139.             $GOTO    ULES2
  1140. ULES1:         DW    SUBB,    ZLESS
  1141. ULES2:         DW    SEMIS
  1142.  
  1143. ;=:   >        test for second item > top of stack    n1 n2 -- f
  1144.  
  1145.         $COLON    81H,,!!!>,GREAT
  1146.         DW    SWAP,    LESS,    SEMIS
  1147.  
  1148. ;=C   ROT    bring the third stack item to top    n1 n2 n3 -- n2 n3 n1
  1149.  
  1150.         $CODE    83H,RO,T,ROT
  1151.         POP    DX
  1152.         POP    BX
  1153.         POP    AX
  1154.         PUSH    BX
  1155.         JMP    DPUSH
  1156.  
  1157. ;=:   SPACE    output a blank                --
  1158.  
  1159.         $COLON    85H,SPAC,E,SPACE
  1160.         DW    BLS,    EMIT,    SEMIS
  1161.  
  1162. ;=:   -DUP    duplicate the top number if it isn't 0    n -- n [n]
  1163.  
  1164.         $COLON    84H,-DU,P,DDUP
  1165.         DW    DUPP
  1166.             $GO?0    DDUP1
  1167.         DW    DUPP
  1168. DDUP1:         DW    SEMIS
  1169.  
  1170. ;=:   TRAVERSE    move across a fig-FORTH name field    addr1 n -- addr2
  1171.  
  1172.         $COLON    88H,TRAVERS,E,TRAV
  1173.         DW    SWAP
  1174. TRAV1:         DW    OVER,    PLUS
  1175.         DW    LIT,    7FH
  1176.         DW    OVER,    CAT,    LESS
  1177.             $GO?0    TRAV1
  1178.         DW    SWAP,    DROP,    SEMIS
  1179.  
  1180. ;=:   LATEST    return the top NFA in CURRENT        -- NFA
  1181.  
  1182.         $COLON    86H,LATES,T,LATES
  1183.         DW    CURR,    AT,    AT,    SEMIS
  1184.  
  1185. ;=:   LFA    convert a PFA to LFA            PFA -- LFA
  1186.  
  1187.         $COLON    83H,LF,A,LFA
  1188.         DW    LIT,    4
  1189.         DW    SUBB,    SEMIS
  1190.  
  1191. ;=:   CFA    convert a PFA to CFA            PFA -- CFA
  1192.  
  1193.         $COLON    83H,CF,A,CFA
  1194.         DW    TWO,    SUBB,    SEMIS
  1195.  
  1196. ;=:*  NFA    convert a PFA to NFA            PFA -- NFA
  1197.  
  1198.         $COLON    83H,NF,A,NFA
  1199.         DW    LIT,    5
  1200.         DW    SUBB
  1201.  
  1202.     IF    _ALIGN
  1203.         DW    DUPP,    CAT
  1204.         DW    LIT,    90H,    EQUAL    ;90H==NOP!
  1205.             $GO?0    NFA1
  1206.         DW    ONEM
  1207. NFA1:
  1208.     ENDIF
  1209.  
  1210.         DW    LIT,    -1
  1211.         DW    TRAV,    SEMIS
  1212.  
  1213. ;=:*  PFA    convert a NFA to PFA            NFA -- PFA
  1214.  
  1215.         $COLON    83H,PF,A,PFA
  1216.         DW    ONE,    TRAV
  1217.     IF    _ALIGN
  1218.         DW    LIT,    6,    PLUS
  1219.         DW    LIT,    -2,    ANDD
  1220.     ELSE
  1221.         DW    LIT,    5,    PLUS
  1222.     ENDIF
  1223.         DW    SEMIS
  1224.  
  1225. ;=:   !CSP    save SP at CSP                --
  1226.  
  1227.         $COLON    84H,!!!!CS,P,SCSP
  1228.         DW    SPAT,    CSPP
  1229.         DW    STORE,    SEMIS
  1230.  
  1231. ;=:   ?ERROR    issue error message m if f is TRUE    f m --
  1232.  
  1233.         $COLON    86H,?ERRO,R,QERR
  1234.         DW    SWAP
  1235.             $GO?0    QERR1
  1236.         DW    ERROR
  1237.             $GOTO    QERR2
  1238. QERR1:         DW    DROP
  1239. QERR2:         DW    SEMIS
  1240.  
  1241. ;=:   ?COMP    issue a message if not compiling    --
  1242.  
  1243.         $COLON    85H,?COM,P,QCOMP
  1244.         DW    STATE,    AT
  1245.         DW    ZEQU,    LIT,    17
  1246.         DW    QERR,    SEMIS
  1247.  
  1248. ;=:   ?EXEC    issue a message if not executing    --
  1249.  
  1250.         $COLON    85H,?EXE,C,QEXEC
  1251.         DW    STATE,    AT
  1252.         DW    LIT,    18
  1253.         DW    QERR,    SEMIS
  1254.  
  1255. ;=:   ?PAIRS    issue a message if n1 <> n2        n1 n2 --
  1256.  
  1257.         $COLON    86H,?PAIR,S,QPAIR
  1258.         DW    SUBB
  1259.         DW    LIT,    19
  1260.         DW    QERR,    SEMIS
  1261.  
  1262. ;=:   ?CSP    issue a message if SP <> (CSP)        --
  1263.  
  1264.         $COLON    84H,?CS,P,QCSP
  1265.         DW    SPAT,    CSPP,    AT,    SUBB
  1266.         DW    LIT,    20
  1267.         DW    QERR,    SEMIS
  1268.  
  1269. ;=:   ?LOADING    issue a message if not loading        --
  1270.  
  1271.         $COLON    88H,?LOADIN,G,QLOAD
  1272.         DW    BLK,    AT,    ZEQU
  1273.         DW    LIT,    22
  1274.         DW    QERR,    SEMIS
  1275.  
  1276. ;=:   COMPILE    compile the following word at run time    --
  1277.  
  1278.         $COLON    87H,COMPIL,E,COMP
  1279.         DW    QCOMP
  1280.         DW    FROMR,    DUPP,    TWOP,    TOR
  1281.         DW    AT,    COMMA,    SEMIS
  1282.  
  1283. ;=:   [        suspend compilation to do calculations    --
  1284.  
  1285.         $COLON    0C1H,,[,LBRAC
  1286.         DW    ZERO,    STATE,    STORE,    SEMIS
  1287.  
  1288. ;=:   ]        resume compilation after [        --
  1289.  
  1290.         $COLON    81H,,],RBRAC
  1291.         DW    LIT,    0C0H
  1292.         DW    STATE,    STORE,    SEMIS
  1293.  
  1294. ;=:   SMUDGE    make the latest definition unFINDable    --
  1295.  
  1296.         $COLON    86H,SMUDG,E,SMUDG
  1297.         DW    LATES
  1298.         DW    LIT,    20H
  1299.         DW    TOGGL,    SEMIS
  1300.  
  1301. ;=:   HEX    set the current number base to 16    --
  1302.  
  1303.         $COLON    83H,HE,X
  1304.         DW    LIT,    16
  1305.         DW    BASE,    STORE,    SEMIS
  1306.  
  1307. ;=:   DECIMAL    set the current number base to 10    --
  1308.  
  1309.         $COLON    87H,DECIMA,L,DECA
  1310.         DW    LIT,    10
  1311.         DW    BASE,    STORE,    SEMIS
  1312.  
  1313. ;=:   (;CODE)    run time code for ;CODE            --
  1314.  
  1315.         $COLON    87H,(!!!;CODE,),PSCOD
  1316.         DW    FROMR,    LATES,    PFA
  1317.         DW    CFA,    STORE,    SEMIS
  1318.  
  1319. ;=:   ;CODE    end colon compilation, start CODE    --
  1320.  
  1321.         $COLON    0C5H,!!!;COD,E,SEMIC
  1322.         DW    QCSP
  1323.         DW    COMP,    PSCOD,    LBRAC
  1324. SEMI1        DW    NOOP    ; (ASSEMBLER)
  1325.         DW    SEMIS
  1326.  
  1327. ;=:   <BUILDS    define compile time behavior        --
  1328.  
  1329.         $COLON    87H,!!!<BUILD,S,BUILD
  1330.         DW    ZERO,    CON,    SEMIS
  1331.  
  1332. ;=:   DOES>    define run time behavior        --
  1333.  
  1334.         $COLON    85H,DOES,!!!>,DOES
  1335.         DW    FROMR,    LATES,    PFA,    STORE
  1336.         DW    PSCOD
  1337.  
  1338. DODOE:         XCHG    BP,SP        ;get RP
  1339.         PUSH    SI        ;RP:=IP
  1340.         XCHG    BP,SP
  1341.         INC    DX        ;point W to PFA
  1342.         MOV    BX,DX
  1343.         MOV    SI,[BX]        ;IP:=(PFA)
  1344.         INC    DX
  1345.         INC    DX        ;W points to PFA
  1346.         PUSH    DX
  1347.         JMP    NEXT
  1348.  
  1349. ;=:   COUNT    prepare to type a string        addr -- addr+1 n
  1350.  
  1351.         $COLON    85H,COUN,T,COUNT
  1352.         DW    DUPP,    ONEP,    SWAP,    CAT,    SEMIS
  1353.  
  1354. ;=:   TYPE    output n characters beginning at addr    addr n --
  1355.  
  1356.         $COLON    84H,TYP,E,TYPES
  1357.         DW    DDUP
  1358.             $GO?0    TYPE1
  1359.         DW    OVER,    PLUS
  1360.         DW    SWAP,    XDO
  1361. TYPE2:         DW    IDO,    CAT,    EMIT
  1362.             $LOOP    TYPE2
  1363.             $GOTO    TYPE3
  1364. TYPE1:         DW    DROP
  1365. TYPE3:         DW    SEMIS
  1366.  
  1367. ;=:   -TRAILING    adjust addr/n to avoid trailing blanks    addr n1 -- addr n2
  1368.  
  1369.         $COLON    89H,-TRAILIN,G,DTRAI
  1370.         DW    DUPP,    ZERO,    XDO
  1371. DTRA1:         DW    OVER,    OVER,    PLUS
  1372.         DW    ONE,    SUBB,    CAT
  1373.         DW    BLS,    SUBB
  1374.             $GO?0    DTRA2
  1375.         DW    LEAVE
  1376.             $GOTO    DTRA3
  1377. DTRA2:         DW    ONE,    SUBB
  1378. DTRA3:             $LOOP    DTRA1
  1379.         DW    SEMIS
  1380.  
  1381. ;=:   (.")    run time code for ."            --
  1382.  
  1383.         $COLON    84H,(.!!!",),PDOTQ
  1384.         DW    RR
  1385.         DW    COUNT,    DUPP,    ONEP
  1386.         DW    FROMR,    PLUS,    TOR
  1387.         DW    TYPES,    SEMIS
  1388.  
  1389. ;=:   ."    print the following string        --
  1390.  
  1391.         $COLON    0C2H,.,!!!",DOTQ
  1392.         DW    LIT,    '"'
  1393.         DW    STATE,    AT
  1394.             $GO?0    DOTQ1
  1395.         DW    COMP
  1396.         DW    PDOTQ,    WORDS,    HERE
  1397.         DW    CAT,    ONEP,    ALLOT
  1398.             $GOTO    DOTQ2
  1399. DOTQ1:         DW    WORDS,    HERE,    COUNT,    TYPES
  1400. DOTQ2:         DW    SEMIS
  1401.  
  1402. ;=:   EXPECT    input up to n characters to addr    addr n --
  1403.  
  1404.         $COLON    86H,EXPEC,T,EXPEC
  1405.         DW    OVER,    PLUS,    OVER
  1406.         DW    XDO
  1407. EXPE1:         DW    KEY,    DUPP
  1408.         DW    LIT,    0EH
  1409.         DW    PORIG,    AT,    EQUAL
  1410.             $GO?0    EXPE2
  1411.         DW    DROP,    DUPP,    IDO
  1412.         DW    EQUAL,    DUPP,    FROMR
  1413.         DW    TWO,    SUBB,    PLUS
  1414.         DW    TOR
  1415.             $GO?0    EXPE6
  1416.         DW    LIT,    BELL
  1417.             $GOTO    EXPE7
  1418. EXPE6:         DW    LIT,    BSOUT,    EMIT
  1419.         DW    BLS,    EMIT
  1420.         DW    LIT,    BSOUT
  1421. EXPE7:             $GOTO    EXPE3
  1422. EXPE2:         DW    DUPP,    LIT,    ACR
  1423.         DW    EQUAL
  1424.             $GO?0    EXPE4
  1425.         DW    LEAVE,    DROP,    BLS,    ZERO
  1426.             $GOTO    EXPE5
  1427. EXPE4:         DW    DUPP
  1428. EXPE5:         DW    IDO
  1429.         DW    CSTOR,    ZERO,    IDO,    ONEP
  1430.         DW    STORE
  1431. EXPE3:         DW    EMIT
  1432.             $LOOP    EXPE1
  1433.         DW    DROP,    SEMIS
  1434.  
  1435. ;=:   QUERY    EXPECT 80 characters to TIB        --
  1436.  
  1437.         $COLON    85H,QUER,Y,QUERY
  1438.         DW    TIB,    AT
  1439.         DW    LIT,    80,    EXPEC
  1440.         DW    ZERO,    INN,    STORE,    SEMIS
  1441.  
  1442. ;=:   <nul>    0 in input: resets interpreter        --
  1443.  
  1444.         _NFA    = $
  1445.         DB    0C1H,80H    ;zero header
  1446.         $LINKS    DOCOL
  1447.  
  1448.         DW    BLK,    AT
  1449.             $GO?0    NULL1
  1450.         DW    ONE,    BLK,    PSTOR
  1451.         DW    ZERO,    INN,    STORE
  1452.         DW    BLK,    AT
  1453.         DW    BSCR,    ONE,    SUBB,    ANDD
  1454.         DW    ZEQU
  1455.             $GO?0    NULL2
  1456.         DW    QEXEC,    FROMR,    DROP
  1457. NULL2:             $GOTO    NULL3
  1458. NULL1:         DW    FROMR,    DROP
  1459. NULL3:         DW    SEMIS
  1460.  
  1461. ;=C   FILL    fill n bytes at address with c        addr n c --
  1462.  
  1463.         $CODE    84H,FIL,L,FILL
  1464.         POP    AX        ;fill char
  1465.         POP    CX        ;fill count
  1466.         POP    DI        ;destination address
  1467.         MOV    BX,DS
  1468.         MOV    ES,BX        ;same segment
  1469.         CLD            ;fill toward higher address
  1470.     REP    STOSB            ;GO!
  1471.         JMP    NEXT
  1472.  
  1473. ;=:   ERASE    fill n bytes at addr with 0's        addr n --
  1474.  
  1475.         $COLON    85H,ERAS,E,ERASEE
  1476.         DW    ZERO,    FILL,    SEMIS
  1477.  
  1478. ;=:   BLANKS    fill n bytes at addr with blanks    addr n --
  1479.  
  1480.         $COLON    86H,BLANK,S,BLANK
  1481.         DW    BLS,    FILL,    SEMIS
  1482.  
  1483. ;=:   HOLD    insert char in formatted output        c --
  1484.  
  1485.         $COLON    84H,HOL,D,HOLD
  1486.         DW    LIT,    -1
  1487.         DW    HLD,    PSTOR
  1488.         DW    HLD,    AT,    CSTOR,    SEMIS
  1489.  
  1490. ;=:   PAD    returns addr of the text output buffer    -- addr
  1491.  
  1492.         $COLON    83H,PA,D,PAD
  1493.         DW    HERE,    LIT,    68,    PLUS,    SEMIS
  1494.         DW    PLUS,    SEMIS
  1495.  
  1496. ;=:   WORD    get a word delimited by char to HERE    c --
  1497.  
  1498.         $COLON    84H,WOR,D,WORDS
  1499.         DW    BLK,    AT
  1500.             $GO?0    WORD1
  1501.         DW    BLK,    AT,    BLOCK
  1502.             $GOTO    WORD2
  1503. WORD1:         DW    TIB,    AT
  1504. WORD2:         DW    INN,    AT,    PLUS,    SWAP
  1505.         DW    ENCL,    HERE
  1506.         DW    LIT,    34
  1507.         DW    BLANK,    INN,    PSTOR
  1508.         DW    OVER,    SUBB,    TOR
  1509.         DW    RR,    HERE,    CSTOR
  1510.         DW    PLUS,    HERE,    ONEP
  1511.         DW    FROMR,    CMOVE,    SEMIS
  1512.  
  1513. ;=:   (NUMBER)    ASCII to binary conversion primitive    d1 addr1 -- d2 addr2
  1514.  
  1515.         $COLON    88H,(NUMBER,),PNUMB
  1516. PNUM1:         DW    ONEP
  1517.         DW    DUPP,    TOR
  1518.         DW    CAT,    BASE,    AT,    DIGIT
  1519.             $GO?0    PNUM2
  1520.         DW    SWAP,    BASE,    AT,    USTAR
  1521.         DW    DROP,    ROT,    BASE,    AT
  1522.         DW    USTAR,    DPLUS
  1523.         DW    DPL,    AT,    ONEP
  1524.             $GO?0    PNUM3
  1525.         DW    ONE,    DPL,    PSTOR
  1526. PNUM3:         DW    FROMR
  1527.             $GOTO    PNUM1
  1528. PNUM2:         DW    FROMR,    SEMIS
  1529.  
  1530. ;=:   NUMBER    convert string at addr to 32-bit number    addr -- d
  1531.  
  1532.         $COLON    86H,NUMBE,R,NUMB
  1533.         DW    ZERO,    ZERO
  1534.         DW    ROT,    DUPP,    ONEP,    CAT
  1535.         DW    LIT,    "-",    EQUAL
  1536.         DW    DUPP,    TOR,    PLUS
  1537.         DW    LIT,    -1
  1538. NUMB1:         DW    DPL,    STORE
  1539.         DW    PNUMB
  1540.         DW    DUPP,    CAT,    BLS,    SUBB
  1541.             $GO?0    NUMB2
  1542.         DW    DUPP,    CAT
  1543.         DW    LIT,    ".",    SUBB
  1544.         DW    ZERO,    QERR,    ZERO
  1545.             $GOTO    NUMB1
  1546. NUMB2:         DW    DROP,    FROMR
  1547.             $GO?0    NUMB3
  1548.         DW    DMINU
  1549. NUMB3:         DW    SEMIS
  1550.  
  1551. ;=:   -FIND    search dictionary for next input word    -- [PFA b] f
  1552.  
  1553.         $COLON    85H,-FIN,D,DFIND
  1554.         DW    BLS,    WORDS
  1555.         DW    HERE,    CONT,    AT,    AT
  1556.         DW    PFIND,    DUPP,    ZEQU
  1557.             $GO?0    DFIN1
  1558.         DW    DROP
  1559.         DW    HERE,    LATES,    PFIND
  1560. DFIN1:         DW    SEMIS
  1561.  
  1562. ;=:   (ABORT)    error function when WARNING is -1    --
  1563.  
  1564.         $COLON    87H,(ABORT,),PABOR
  1565.         DW    ABORT,    SEMIS
  1566.  
  1567. ;=:   ERROR    system error handler - n is line no.    n -- [IN BLK]
  1568.  
  1569.         $COLON    85H,ERRO,R,ERROR
  1570.         DW    WARN,    AT,    ZLESS
  1571.             $GO?0    ERRO1
  1572.         DW    PABOR
  1573. ERRO1:         DW    HERE,    COUNT,    TYPES
  1574.         DW    PDOTQ
  1575.         DB    2,"? "
  1576.         DW    MESS
  1577.         DW    SPSTO
  1578.         DW    BLK,    AT,    DDUP
  1579.             $GO?0    ERRO2
  1580.         DW    INN,    AT,    SWAP
  1581. ERRO2:         DW    QUIT
  1582.  
  1583. ;=:   ID.    print dictionary name field        NFA --
  1584.  
  1585.         $COLON    83H,ID,.,IDDOT
  1586.         DW    PAD
  1587.         DW    LIT,    32
  1588.         DW    LIT,    '_'
  1589.         DW    FILL
  1590.         DW    DUPP,    PFA,    LFA
  1591.         DW    OVER,    SUBB
  1592.         DW    PAD,    SWAP,    CMOVE
  1593.         DW    PAD,    COUNT
  1594.         DW    LIT,    1FH    ;use low 5 bits of length
  1595.         ;Last char of name must have MSB reset!
  1596.         DW    ANDD,    DUPP,    PAD,    PLUS
  1597.         DW    LIT,    80H,    TOGGL
  1598.         DW    TYPES,    SPACE,    SEMIS
  1599.         DW    ANDD,    TYPES,    SPACE,    SEMIS
  1600.  
  1601. ;=:*  CREATE    create a dictionary header        --
  1602.  
  1603.         $COLON    86H,CREAT,E,CREAT
  1604.         DW    DFIND
  1605.             $GO?0    CREA1
  1606.         DW    DROP,    NFA,    IDDOT
  1607.         DW    LIT,    4,    MESS    ;"not unique"
  1608.         DW    SPACE
  1609. CREA1:         DW    HERE,    DUPP,    CAT
  1610.         DW    NWIDTH,    AT,    MIN
  1611.         DW    ONEP,    ALLOT
  1612.         DW    DUPP
  1613.         DW    LIT,    0A0H
  1614.         DW    TOGGL            ;smudge it
  1615.         DW    HERE,    ONE,    SUBB
  1616.         DW    LIT,    80H
  1617.         DW    TOGGL            ;last char has bit 8 set
  1618.  
  1619.     IF    _ALIGN
  1620. ;This section of code forces the body of a compiled FORTH word to
  1621. ;lie on even addresses.  This allows the threaded CFA's to be
  1622. ;fetched by the inner interpreter in one bus cycle.  For the 8088
  1623. ;this means nothing, and the extra space required for alignment
  1624. ;should be saved by setting _ALIGN to FALSE.  The literal 90H is
  1625. ;used because MASM uses NOP's to align words.  NFA expects
  1626. ;90H to be used also.
  1627.         DW    LIT,    90H,    CCOMM
  1628.         DW    DP,    AT
  1629.         DW    LIT,    -2,    ANDD
  1630.         DW    DP,    STORE
  1631.     ENDIF
  1632.         DW    LATES,    COMMA        ;compile LFA
  1633.         DW    CURR,    AT,    STORE    ;update vocabulary
  1634.         DW    HERE,    TWOP,    COMMA,    SEMIS    ;CFA:=PFA
  1635.  
  1636. ;=:   [COMPILE]    compile an otherwise immediate word    --
  1637.  
  1638.         $COLON    0C9H,[COMPILE,]
  1639.         DW    DFIND
  1640.         DW    ZEQU,    ZERO,    QERR
  1641.         DW    DROP,    CFA,    COMMA,    SEMIS
  1642.  
  1643. ;=:   LITERAL    compile n to be used at run time    n --
  1644.  
  1645.         $COLON    0C7H,LITERA,L,LITER
  1646.         DW    STATE,    AT
  1647.             $GO?0    LITE1
  1648.         DW    COMP,    LIT,    COMMA
  1649. LITE1:         DW    SEMIS
  1650.  
  1651. ;=:   DLITERAL    compile d to be used at run time    d --
  1652.  
  1653.         $COLON    0C8H,DLITERA,L,DLITE
  1654.         DW    STATE,    AT
  1655.             $GO?0    DLIT1
  1656.         DW    SWAP,    LITER,    LITER
  1657. DLIT1:        DW    SEMIS
  1658.  
  1659. ;=:   ?STACK    check if the stack is out of bounds    --
  1660.  
  1661.         $COLON    86H,?STAC,K,QSTAC
  1662.         DW    SPAT,    SZERO,    AT
  1663.         DW    SWAP,    ULESS,    ONE,    QERR    ;underflow
  1664.         DW    SPAT,    HERE
  1665.         DW    LIT,    80H
  1666.         DW    PLUS,    ULESS
  1667.         DW    LIT,    7
  1668.         DW    QERR                ;overflow
  1669.         DW    SEMIS
  1670.  
  1671. ;=:   INTERPRET    outer text interpreter            --
  1672.  
  1673.         $COLON    89H,INTERPRE,T,INTER
  1674. INTE1:         DW    DFIND            ;begin
  1675.             $GO?0    INTE2
  1676.         DW    STATE,     AT,    LESS
  1677.             $GO?0    INTE3
  1678.         DW    CFA,    COMMA        ;compile it
  1679.             $GOTO    INTE4
  1680. INTE3:         DW    CFA,    EXEC        ;execute it
  1681. INTE4:         DW    QSTAC
  1682.             $GOTO    INTE5
  1683. INTE2:         DW    HERE,    NUMB,    DPL,    AT,    ONEP
  1684.             $GO?0    INTE6
  1685.         DW    DLITE            ;32-bit number
  1686.             $GOTO    INTE7
  1687. INTE6:         DW    DROP,    LITER        ;16-bit number
  1688. INTE7:        DW    QSTAC
  1689. INTE5:            $GOTO    INTE1        ;repeat forever
  1690.  
  1691. ;=:   IMMEDIATE    mark the latest word to be executed    --
  1692.  
  1693.         $COLON    89H,IMMEDIAT,E
  1694.         DW    LATES
  1695.         DW    LIT,    40H    ;bit 7 is precedence
  1696.         DW    TOGGL,    SEMIS
  1697.  
  1698. ;=:   VOCABULARY    define a new vocabulary        --
  1699.  
  1700.         $COLON    8AH,VOCABULAR,Y
  1701.         DW    BUILD
  1702.         DW    LIT,    0A081H
  1703.         DW    COMMA
  1704.         DW    CURR,    AT
  1705.         DW    CFA,    COMMA,    HERE,    VOCL
  1706.         DW    AT,    COMMA,    VOCL,    STORE
  1707.         DW    DOES
  1708. DOVOC:         DW    TWOP,    CONT,    STORE,    SEMIS
  1709.  
  1710. ;=:   FORTH    FORTH vocabulary header            --
  1711.  
  1712.         $DOES    0C5H,FORT,H,FORTH
  1713.         DW    DOVOC
  1714.         DW    0A081H        ;fake a null name field!
  1715.         DW    LASTNFA        ;link changes as def's are added
  1716.         DW    0        ;end of voc list
  1717.  
  1718. ;=:   DEFINITIONS    set CURRENT to CONTEXT        --
  1719.  
  1720.         $COLON    8BH,DEFINITION,S,DEFIN
  1721.         DW    CONT,    AT
  1722.         DW    CURR,    STORE,    SEMIS
  1723.  
  1724. ;=:   (        begin a comment ended by ')'        --
  1725.  
  1726.         $COLON    0C1H,,(
  1727.         DW    LIT,    ')',    WORDS,    SEMIS
  1728.  
  1729. ;=:   QUIT    halt execution, reset interpreter    --
  1730.  
  1731.         $COLON    84H,QUI,T,QUIT
  1732.         DW    ZERO,    BLK,    STORE
  1733.         DW    LBRAC
  1734. QUIT1:         DW    RPSTO,    CR,    QUERY
  1735.         DW    INTER
  1736.         DW    STATE,    AT,    ZEQU
  1737.             $GO?0    QUIT2
  1738.         DW    PDOTQ
  1739.         DB    2,"ok"
  1740. QUIT2:             $GOTO    QUIT1
  1741.  
  1742. ;=:   ABORT    clear stacks and begin execution    --
  1743.  
  1744.         $COLON    85H,ABOR,T,ABORT
  1745.         DW    SPSTO,    DECA,    QSTAC,    CR
  1746.         DW    DOTCPU,    PDOTQ
  1747.         DB    16H,'Fig-FORTH  Version '
  1748.         DB    FIGREL+30H, '.', FIGREV+30H
  1749.         DW    LIT,    10,    PORIG,    CAT
  1750.         DW    LIT,    41H,    PLUS,    EMIT
  1751.         DW    FORTH,    DEFIN
  1752.         DW    LIT,    0,    PRTER,    STORE    ;Reset echo
  1753.  
  1754. ; The following lines add command line interpretation.
  1755. ; Any text at 80H is copied to the TIB and interpreted.
  1756. ; This code should probably go somewhere else, but I never bothered
  1757. ; to move it...
  1758.  
  1759.         DW    LIT,    80H,    COUNT,    DUPP    ;anyone here?
  1760.             $GO?0    AB1            ;no...
  1761.         DW    ZERO,    LIT,    80H,    CSTOR    ;don't do twice
  1762.         DW    TIB,    AT,    DUPP
  1763.         DW    LIT,    64,    ERASEE        ;ensure NUL end
  1764.         DW    SWAP,    CMOVE            ;move it
  1765.         DW    ZERO,    INN,    STORE
  1766.         DW    ZERO,    BLK,    STORE,    LBRAC
  1767.         DW    CR,    CR,    INTER        ;interpret it
  1768.             $GOTO AB2
  1769. AB1:        DW    DROP,    DROP            ;nothing to do
  1770. AB2:        DW    QUIT                ;back to normal
  1771.  
  1772. ; Warm start vector comes here
  1773.  
  1774. WRM:         MOV    SI,OFFSET WRM1
  1775.         JMP    NEXT
  1776. WRM1        DW    WARM
  1777.  
  1778. ;=:   WARM    empty disk buffers and abort        --
  1779.  
  1780.         $COLON    84H,WAR,M,WARM
  1781.         DW    MTBUF,    ABORT
  1782.  
  1783. ; Cold start vector comes here
  1784.  
  1785. CLD:         MOV    SI,OFFSET CLD1        ;initialize IP
  1786.         MOV    AX,CS
  1787.         MOV    DS,AX            ;all in one segment
  1788.         MOV    SP,12H[ORIG]        ;initialize SP
  1789.         MOV    SS,AX
  1790.         MOV    ES,AX
  1791.         CLD                ;SI gets incremented
  1792.         MOV    BP,RPP            ;init RP
  1793.  
  1794.         CALL NEAR PTR SYSINIT    ;system dependent initialization
  1795.  
  1796.         JMP    NEXT
  1797.  
  1798. CLD1         DW    COLD
  1799.  
  1800. ;=:*  COLD    full initialization and restart        --
  1801.  
  1802.         $COLON    84H,COL,D,COLD
  1803.         DW    DRZER,    MTBUF
  1804.         DW    FIRST,    USE,    STORE
  1805.         DW    FIRST,    PREV,    STORE
  1806.         DW    LIT,    ORIG+12H
  1807.         DW    LIT,    UP,    AT
  1808.         DW    LIT,    6,    PLUS
  1809.         DW    LIT,    16,    CMOVE    ;USER variables
  1810.         DW    LIT,    ORIG+12,AT
  1811.         DW    LIT,    FORTH+6,STORE    ;vocabulary link
  1812.  
  1813. ; Initialize i/o vectors
  1814.  
  1815.         DW    LIT,    PKEY,    TICKEY,        STORE
  1816.         DW    LIT,    PEMIT,    TICKEMIT,    STORE
  1817.         DW    LIT,    PCR,    TICKCR,        STORE
  1818.         DW    LIT,    BLKRD,    TICKBRD,    STORE
  1819.         DW    LIT,    BLKWRT,    TICKBWRT,    STORE
  1820.  
  1821.         DW    ABORT
  1822.  
  1823. ;=C   S->D    convert a 16-bit number to 32-bits    n -- d
  1824.  
  1825.         _NFA    = $
  1826.         DB    84H,'S->','D'+80H
  1827.         $LINKS    $+2,STOD
  1828.  
  1829.         POP    DX        ;n, becomes LSW of result
  1830.         SUB    AX,AX
  1831.         OR    DX,DX        ;is n negative?
  1832.         JNS    STOD1        ;no, MSW:=AX=0
  1833.         DEC    AX        ;yes, MSW:=-1
  1834. STOD1:         JMP    DPUSH        ;S1=MSW, S2=LSW
  1835.  
  1836. ;=:   +-    apply the sign of n2 to n1        n1 n2 -- n3
  1837.  
  1838.         $COLON    82H,+,-,PM
  1839.         DW    ZLESS
  1840.             $GO?0    PM1
  1841.         DW    MINUS
  1842. PM1:         DW    SEMIS
  1843.  
  1844. ;=:   D+-    apply the sign of n to d1        d1 n -- d2
  1845.  
  1846.         $COLON    83H,D+,-,DPM
  1847.         DW    ZLESS
  1848.             $GO?0    DPM1
  1849.         DW    DMINU
  1850. DPM1:         DW    SEMIS
  1851.  
  1852. ;=:   ABS    take the absolute value of n1        n1 -- n2
  1853.  
  1854.         $COLON    83H,AB,S,ABBS
  1855.         DW    DUPP,    PM,    SEMIS
  1856.  
  1857. ;=:   DABS    take the absolute value of d1        d1 -- d2
  1858.  
  1859.         $COLON    84H,DAB,S,DABS
  1860.         DW    DUPP,    DPM,    SEMIS
  1861.  
  1862. ;=:   MIN    return the smaller of n1 and n2        n1 n2 -- n
  1863.  
  1864.         $COLON    83H,MI,N,MIN
  1865.         DW    TDUP,    GREAT
  1866.             $GO?0    MIN1
  1867.         DW    SWAP
  1868. MIN1:         DW    DROP,    SEMIS
  1869. ;=:   MAX    return the larger of two numbers    n1 n2 -- n
  1870.  
  1871.         $COLON    83H,MA,X,MAX
  1872.         DW    TDUP,    LESS
  1873.             $GO?0    MAX1
  1874.         DW    SWAP
  1875. MAX1:         DW    DROP,    SEMIS
  1876.  
  1877. ;=:   M*    mixed multiplication            n1 n2 -- d
  1878.  
  1879.         $COLON    82H,M,*,MSTAR
  1880.         DW    TDUP,    XORR,    TOR
  1881.         DW    ABBS
  1882.         DW    SWAP,    ABBS,    USTAR
  1883.         DW    FROMR,    DPM,    SEMIS
  1884.  
  1885. ;=:   M/    mixed division                d n1 -- nrem nquot
  1886.  
  1887.         $COLON    82H,M,/,MSLAS
  1888.         DW    OVER,    TOR,    TOR
  1889.         DW    DABS
  1890.         DW    RR,    ABBS,    USLAS
  1891.         DW    FROMR,    RR,    XORR
  1892.         DW    PM,    SWAP,    FROMR
  1893.         DW    PM,    SWAP,    SEMIS
  1894.  
  1895. ;=:   *        16-bit signed multipication        n1 n2 -- n1*n2
  1896.  
  1897.         $COLON    81H,,*,STAR
  1898.         DW    MSTAR,    DROP,    SEMIS
  1899.  
  1900. ;=:   /MOD    16-bit signed division with remainder    n1 n2 -- nrem nquot
  1901.  
  1902.         $COLON    84H,/MO,D,SLMOD
  1903.         DW    TOR,    STOD,    FROMR
  1904.         DW    MSLAS,    SEMIS
  1905.  
  1906. ;=:   /        16-bit signed division            n1 n2 -- nquot
  1907.  
  1908.         $COLON    81H,,/,SLASH
  1909.         DW    SLMOD,    SWAP,    DROP,    SEMIS
  1910.  
  1911. ;=:   MOD    16-bit modulo division            n1 n2 -- nrem
  1912.  
  1913.         $COLON    83H,MO,D,MODD
  1914.         DW    SLMOD,    DROP,    SEMIS
  1915.  
  1916. ;=:   */MOD    scale n1 by the ratio of n2 to n3    n1 n2 n3 -- nrem nquot
  1917.  
  1918.         $COLON    85H,*/MO,D,SSMOD
  1919.         DW    TOR,    MSTAR,    FROMR
  1920.         DW    MSLAS,    SEMIS
  1921.  
  1922. ;=:   */    scale n1 by the ratio of n2 to n3    n1 n2 n3 -- nquot
  1923.  
  1924.         $COLON    82H,*,/,SSLA
  1925.         DW    SSMOD,    SWAP,    DROP,    SEMIS
  1926.  
  1927. ;=:   M/MOD    mixed unsigned scaler            ud1 u -- urem udquot
  1928.  
  1929.         $COLON    85H,M/MO,D,MSMOD
  1930.         DW    TOR,    ZERO,    RR,    USLAS
  1931.         DW    FROMR,    SWAP,    TOR
  1932.         DW    USLAS,    FROMR,    SEMIS
  1933.  
  1934. ;=:   (LINE)    convert a line/screen to addr/count    l s -- addr count
  1935.  
  1936.         $COLON    86H,(LINE,),PLINE
  1937.         DW    TOR
  1938.         DW    LIT,    64
  1939.         DW    BBUF,    SSMOD
  1940.         DW    FROMR,    BSCR,    STAR
  1941.         DW    PLUS
  1942.         DW    BLOCK,    PLUS
  1943.         DW    LIT,    64,    SEMIS
  1944.  
  1945. ;=:   .LINE    type line n1 in screen n2        n1 n2 --
  1946.  
  1947.         $COLON    85H,.LIN,E,DLINE
  1948.         DW    PLINE,    DTRAI,    TYPES,    SEMIS
  1949.  
  1950. ;=:   MESSAGE    type error message n            n --
  1951.  
  1952.         $COLON    87H,MESSAG,E,MESS
  1953.         DW    WARN,    AT
  1954.             $GO?0    MESS1
  1955.         DW    DDUP
  1956.             $GO?0    MESS2
  1957.         DW    LIT,    4
  1958.         DW    OFSET,    AT,    BSCR,    SLASH
  1959.         DW    SUBB,    DLINE,    SPACE
  1960. MESS2:             $GOTO    MESS3
  1961. MESS1:         DW    PDOTQ
  1962.         DB    6,"MSG # "
  1963.         DW    DOT
  1964. MESS3:         DW    SEMIS
  1965.  
  1966.     $REPORT    <FORTH kernel completed>
  1967.  
  1968. INCLUDE    4TH-SYSD.ASM            ;System dependent code
  1969.  
  1970. SUBTTL Disk interface words
  1971. PAGE +
  1972.  
  1973. ;=?   DRIVE    disk drive last accessed        -- addr
  1974.  
  1975.         $VAR    85H,DRIV,E,DRIVE
  1976.         DW    0
  1977.  
  1978. ;=?+  RECORD    disk record last accessed        -- addr
  1979.  
  1980.         $VAR    86H,RECOR,D,REC
  1981.         DW    0
  1982.  
  1983. ;=?+  DTA    disk transfer address last used        -- addr
  1984.  
  1985.         $VAR    83H,DT,A,DTA
  1986.         DW    FIRST
  1987.  
  1988. ;=?   USE    pointer to disk buffer to use next    -- addr
  1989.  
  1990.         $VAR    83H,US,E,USE
  1991.         DW    BUF1
  1992.  
  1993. ;=?   PREV    pointer to disk buffer last accessed    -- addr
  1994.  
  1995.         $VAR    84H,PRE,V,PREV
  1996.         DW    BUF1
  1997.  
  1998. ;=#   #BUFF    total number of block buffers        -- n
  1999.  
  2000.         $CONST    85H,#BUF,F,NOBUF
  2001.         DW    NSCR
  2002.  
  2003. ;=?   DISK-ERROR    status of last disk operation    -- addr
  2004.  
  2005.         $VAR    8AH,DISK-ERRO,R,DSKERR
  2006.         DW    0
  2007.  
  2008. ;=?*  PRINTER    flag controlling printer        -- addr
  2009.  
  2010.         $VAR    87H,PRINTE,R,PRTER
  2011.         DW    0
  2012.  
  2013. ;Block read/write words modified to use execution vectors.
  2014. ;The functions called by BLOCK-READ/-WRITE have the following stack
  2015. ;effect: ( addr blk -- ) and set DISK-ERROR accordingly.
  2016.  
  2017. ;=:+  BLOCK-READ    read one block to addr        addr blk --
  2018.  
  2019.         $COLON    8AH,BLOCK-REA,D,BLOCKRD
  2020.         DW    TICKBRD,    AT,    EXEC,    SEMIS
  2021.  
  2022. ;=:+  BLOCK-WRITE    write one block from addr    addr blk --
  2023.  
  2024.         $COLON    8BH,BLOCK-WRIT,E,BLOCKWRT
  2025.         DW    TICKBWRT,    AT,    EXEC,    SEMIS
  2026.  
  2027. ;=:*  +BUF    advance addr to next buffer        addr1 -- addr2
  2028.  
  2029.         $COLON    84H,+BU,F,PBUF
  2030.         DW    BBUF,    TWOP,    TWOP    ;B/BUF+4
  2031.         DW    PLUS,    DUPP,    LIMIT,    EQUAL
  2032.             $GO?0    PBUF1
  2033.         DW    DROP,    FIRST
  2034. PBUF1:         DW    DUPP,    PREV,    AT
  2035.         DW    SUBB,    SEMIS
  2036.  
  2037. ;=:   UPDATE    mark PREV buffer to be saved        --
  2038.  
  2039.         $COLON    86H,UPDAT,E,UPDAT
  2040.         DW    PREV,    AT,    AT
  2041.         DW    LIT,    8000H
  2042.         DW    ORR
  2043.         DW    PREV,    AT,    STORE,    SEMIS
  2044.  
  2045. ;=:*  EMPTY-BUFFERS    wipe out disk buffers        --
  2046.  
  2047.         $COLON    8DH,EMPTY-BUFFER,S,MTBUF
  2048.         DW    FIRST,    LIMIT,    OVER
  2049.         DW    SUBB,    ERASEE
  2050. ;Modified so that emptied buffers won't look like block 0:
  2051. ;instead, they're all assigned to block 32767.  If you want to
  2052. ;use FORTH on a disk that big - TOO BAD!
  2053.         DW    LIT,    7FFFH
  2054.         DW    NOBUF,    ONEP,    ZERO,    XDO
  2055. MTBUF1:        DW    DUPP,    BUFFE,    DROP
  2056.             $LOOP    MTBUF1
  2057.         DW    DROP,    SEMIS
  2058.  
  2059. ;Words added to save buffers:
  2060.  
  2061. ;=:+  SAVBUF    saves buffer at addr if updated        addr --
  2062.  
  2063.         $COLON    86H,SAVBU,F,SAVBUF
  2064.         DW    DUPP,    TOR,    AT,    ZLESS
  2065.             $GO?0    SVBF1        ;not updated, return
  2066.         DW    RR,    TWOP,    RR,    AT
  2067.         DW    LIT,    7FFFH,    ANDD    ;15-bits only!
  2068.         DW    ZERO,    RSLW        ;write it
  2069.         DW    DSKERR,    AT,    ZEQU
  2070.             $GO?0    SVBF1        ;don't un-update if error
  2071.         DW    RR,    ONEP        ;high byte!
  2072.         DW    LIT,    80H,    TOGGL    ;un-update buffer
  2073. SVBF1:        DW    FROMR,    DROP,    SEMIS
  2074.  
  2075. ;=:+  SAVE-BUFFERS    flush buffers but don't empty    --
  2076.  
  2077.         $COLON    8CH,SAVE-BUFFER,S,SAVBUFS
  2078.         DW    PREV,    AT
  2079. SVBFS1:        DW    PBUF,    OVER,    SAVBUF,    ZEQU
  2080.             $GO?0    SVBFS1
  2081.         DW    DROP,    SEMIS
  2082.  
  2083. ;=:*  BUFFER    assign an available buffer to block n    n -- addr
  2084.  
  2085. ;BUFFER changed to write out ALL dirty buffers when one is found.
  2086.  
  2087.         $COLON    86H,BUFFE,R,BUFFE
  2088.         DW    USE,    AT,    DUPP,    TOR
  2089. BUFF1:         DW    PBUF
  2090.             $GO?0    BUFF1        ;dont use PREV
  2091.         DW    USE,    STORE        ;use this one NEXT!
  2092.         DW    RR,    AT,    ZLESS    ;found a dirty one?
  2093.             $GO?0    BUFF2        ;no
  2094.         DW    SAVBUFS            ;yes, save ALL
  2095. BUFF2:        DW    RR,    STORE        ;set header to n
  2096.         DW    RR,    PREV,    STORE    ;this is now PREV
  2097.         DW    FROMR,    TWOP,    SEMIS    ;leave data addr
  2098.  
  2099. ;=:*  BLOCK    get block n                n -- addr
  2100.  
  2101.         $COLON    85H,BLOC,K,BLOCK
  2102.         DW    OFSET,    AT,    PLUS,    TOR    ;get n+offset
  2103.         DW    PREV,    AT,    DUPP        ;look in PREV first
  2104.         DW    AT,    RR,    SUBB
  2105.         DW    DUPP,    PLUS            ;throw out high bit
  2106.             $GO?0    BLOC1            ;n is in PREV
  2107. BLOC2:         DW    PBUF,    ZEQU            ;check next buffer
  2108.             $GO?0    BLOC3            ;found it
  2109.         DW    DROP,    RR            ;not in buffer
  2110.         DW    BUFFE,    DUPP            ;get a buffer
  2111.         DW    RR,    ONE,    RSLW        ;read blk
  2112.         DW    TWO,    SUBB            ;leave buffer addr
  2113. BLOC3:         DW    DUPP,    AT,    RR,    SUBB    ;check the buffer
  2114.         DW    DUPP,    PLUS,    ZEQU
  2115.             $GO?0    BLOC2
  2116.         DW    DUPP,    PREV,    STORE        ;either found it or read it
  2117. BLOC1:         DW    FROMR,    DROP            ;return
  2118.         DW    TWOP,    SEMIS
  2119.  
  2120. ;T&SCALC now done by D&RCALC in SYSD.ASM file...
  2121.  
  2122. ;=:*  R/W    block read/write, f=1=write, f=2=read    addr blk f --
  2123.  
  2124.         $COLON    83H,R/,W,RSLW
  2125. ;Modified to simply pass the address and blk to the R/W functions
  2126.             $GO?0    RSLW1
  2127.         DW    BLOCKRD
  2128.             $GOTO    RSLW2
  2129. RSLW1:        DW    BLOCKWRT
  2130. RSLW2:        DW    DSKERR,    AT,    DDUP
  2131.             $GO?0    RSLW5        ;OK
  2132.         DW    ZLESS
  2133.             $GO?0    RSLW3
  2134.         DW    LIT,    9        ;Write error
  2135.             $GOTO    RSLW4
  2136. RSLW3:        DW    LIT,    8        ;Read error
  2137. RSLW4:        DW    LIT,    7FFFH        ;Set buffer to 32767
  2138.         DW    PREV,    AT,    STORE    ; to mark as bad
  2139.         DW    WARN,    AT,    ZLESS    ;If WARNING<0 then
  2140.             $GO?0 RSLW6        ;assume he can handle it
  2141.             $GOTO RSLW7        ;otherwise,
  2142. RSLW6:        DW    ZERO,    WARN,    STORE    ;don't try to read!
  2143. RSLW7:        DW    QERR
  2144. RSLW5:        DW    SEMIS
  2145.  
  2146. ;=:*  FLUSH    empty buffers, saving changed ones    --
  2147.  
  2148.         $COLON    85H,FLUS,H,FLUSH
  2149.         DW    NOBUF,    ONEP
  2150.         DW    ZERO,    XDO
  2151. FLUS1:         DW    LIT,    7FFFH,    BUFFE,    DROP
  2152.             $LOOP    FLUS1
  2153.         DW    SEMIS
  2154.  
  2155. ;=:   LOAD    interpret screen n            n --
  2156.  
  2157.         $COLON    84H,LOA,D
  2158.         DW    BLK,    AT,    TOR
  2159.         DW    INN,    AT,    TOR
  2160.         DW    ZERO,    INN,    STORE
  2161.         DW    BSCR,    STAR,    BLK,    STORE
  2162.         DW    INTER
  2163.         DW    FROMR,    INN,    STORE
  2164.         DW    FROMR,    BLK,    STORE
  2165.         DW    SEMIS
  2166.  
  2167. ;=:   -->    continue with next screen        --
  2168.  
  2169.         $COLON    0C3H,--,!!!>
  2170.         DW    QLOAD
  2171.         DW    ZERO,    INN,    STORE
  2172.         DW    BSCR,    BLK,    AT
  2173.         DW    OVER,    MODD,    SUBB
  2174.         DW    BLK,    PSTOR,    SEMIS
  2175. SUBTTL
  2176. PAGE +
  2177.  
  2178.  
  2179. ;=:   '        find next input word in dictionary    -- PFA
  2180.  
  2181.         _NFA    = $
  2182.         DB    0C1H,"'"+80H
  2183.         $LINKS    DOCOL,TICK
  2184.  
  2185.         DW    DFIND,    ZEQU
  2186.         DW    ZERO,    QERR
  2187.         DW    DROP,    LITER,    SEMIS
  2188.  
  2189. ;=:*  FORGET    chop off the top of the dictionary    --
  2190.  
  2191.         $COLON    86H,FORGE,T
  2192.         DW    CURR,    AT
  2193.         DW    CONT,    AT
  2194.         DW    SUBB
  2195.         DW    LIT,    24,    QERR    ;"declare vocabulary"
  2196.         DW    TICK,    DUPP
  2197.         DW    FENCE,    AT,    ULESS    ;note change from fig
  2198.         DW    LIT,    21,    QERR    ;"in protected dictionary"
  2199.         DW    DUPP
  2200.         DW    NFA,    DP,    STORE
  2201.         DW    LFA,    AT
  2202.         DW    CONT,    AT,    STORE,    SEMIS
  2203. SUBTTL Control flow structures
  2204. PAGE
  2205.  
  2206. ;=:   BACK    compile a backward branch offset    target --
  2207.  
  2208.         $COLON    84H,BAC,K,BACK
  2209.         DW    HERE,    SUBB
  2210.         DW    COMMA,    SEMIS
  2211.  
  2212. ;=:   BEGIN    starting point of looping structures    -- HERE 1
  2213.  
  2214.         $COLON    0C5H,BEGI,N
  2215.         DW    QCOMP
  2216.         DW    HERE,    ONE,    SEMIS
  2217.  
  2218. ;=:   ENDIF    end of IF..ELSE..THEN structure        addr 2 --
  2219.  
  2220.         $COLON    0C5H,ENDI,F,ENDIFF
  2221.         DW    QCOMP
  2222.         DW    TWO,    QPAIR
  2223.         DW    HERE,    OVER,    SUBB
  2224.         DW    SWAP,    STORE,    SEMIS
  2225.  
  2226. ;=:   THEN    synonym for ENDIF            addr 2 --
  2227.  
  2228.         $COLON    0C4H,THE,N
  2229.         DW    ENDIFF,    SEMIS
  2230.  
  2231. ;=:   DO    start of DO..LOOP structure        -- HERE 3
  2232.  
  2233.         $COLON    0C2H,D,O
  2234.         DW    COMP,    XDO
  2235.         DW    HERE,    THREE,    SEMIS
  2236.  
  2237. ;=:   LOOP    end of DO..LOOP structure        addr 3 --
  2238.  
  2239.         $COLON    0C4H,LOO,P
  2240.         DW    THREE,    QPAIR
  2241.         DW    COMP,    XLOOP
  2242.         DW    BACK,    SEMIS
  2243.  
  2244. ;=:   +LOOP    end of DO..+LOOP structure        addr 3 --
  2245.  
  2246.         $COLON    0C5H,+LOO,P
  2247.         DW    THREE,    QPAIR
  2248.         DW    COMP,    XPLOO
  2249.         DW    BACK,    SEMIS
  2250.  
  2251. ;=:   UNTIL    end of BEGIN..UNTIL loop        addr 1 --
  2252.  
  2253.         $COLON    0C5H,UNTI,L,UNTIL
  2254.         DW    ONE,    QPAIR
  2255.         DW    COMP,    ZBRAN
  2256.         DW    BACK,    SEMIS
  2257.  
  2258. ;=:   END    synonym for UNTIL            addr 1 --
  2259.  
  2260.         $COLON    0C3H,EN,D
  2261.         DW    UNTIL,    SEMIS
  2262.  
  2263. ;=:   AGAIN    end of BEGIN..AGAIN infinite loop    addr 1 --
  2264.  
  2265.         $COLON    0C5H,AGAI,N,AGAIN
  2266.         DW    ONE,    QPAIR
  2267.         DW    COMP,    BRAN
  2268.         DW    BACK,    SEMIS
  2269.  
  2270. ;=:   REPEAT    end of BEGIN..WHILE..REPEAT structure    addr 1 --
  2271.  
  2272.         $COLON    0C6H,REPEA,T
  2273.         DW    TOR,    TOR
  2274.         DW    AGAIN
  2275.         DW    FROMR,    FROMR
  2276.         DW    TWO,    SUBB
  2277.         DW    ENDIFF,    SEMIS
  2278.  
  2279. ;=:   IF    conditional branch structure        -- 2
  2280.  
  2281.         $COLON    0C2H,I,F,IFF
  2282.         DW    COMP,    ZBRAN
  2283.         DW    HERE,    ZERO,    COMMA
  2284.         DW    TWO,    SEMIS
  2285.  
  2286. ;=:   ELSE    optional part of IF..ELSE..THEN        addr 2 -- HERE 2
  2287.  
  2288.         $COLON    0C4H,ELS,E
  2289.         DW    TWO,    QPAIR
  2290.         DW    COMP,    BRAN
  2291.         DW    HERE,    ZERO,    COMMA
  2292.         DW    SWAP
  2293.         DW    TWO,    ENDIFF,    TWO
  2294.         DW    SEMIS
  2295.  
  2296. ;=:   WHILE    conditional loop BEGIN..WHILE..REPEAT    addr 2 -- HERE 4
  2297.  
  2298.         $COLON    0C5H,WHIL,E
  2299.         DW    IFF,    TWOP,    SEMIS
  2300. SUBTTL Output formatting words
  2301. PAGE +
  2302.  
  2303.  
  2304. ;=:   SPACES    type n spaces                n --
  2305.  
  2306.         $COLON    86H,SPACE,S,SPACS
  2307.         DW    ZERO,    MAX
  2308.         DW    DDUP
  2309.             $GO?0    SPAX1
  2310.         DW    ZERO,    XDO
  2311. SPAX2:         DW    SPACE
  2312.             $LOOP    SPAX2
  2313. SPAX1:         DW    SEMIS
  2314.  
  2315. ;=:   <#    begin number formatting            --
  2316.  
  2317.         $COLON    82H,!!!<,#,BDIGS
  2318.         DW    PAD,    HLD,    STORE
  2319.         DW    SEMIS
  2320.  
  2321. ;=:   #>    end number formatting            d -- addr count
  2322.  
  2323.         $COLON    82H,#,!!!>,EDIGS
  2324.         DW    DROP,    DROP
  2325.         DW    HLD,    AT
  2326.         DW    PAD
  2327.         DW    OVER,    SUBB,    SEMIS
  2328.  
  2329. ;=:   SIGN    places a '-' in output if n < 0        n d -- d
  2330.  
  2331.         $COLON    84H,SIG,N,SIGN
  2332.         DW    ROT,    ZLESS
  2333.             $GO?0    SIGN1
  2334.         DW    LIT,    '-',    HOLD
  2335. SIGN1:         DW    SEMIS
  2336.  
  2337. ;=:   #        convert one digit of d1 to ASCII    d1 -- d2
  2338.  
  2339.         $COLON    81H,,#,DIG
  2340.         DW    BASE,    AT,    MSMOD
  2341.         DW    ROT
  2342.         DW    LIT,    9
  2343.         DW    OVER,    LESS
  2344.             $GO?0    DIG1
  2345.         DW    LIT,    7,    PLUS
  2346. DIG1:         DW    LIT,    '0',    PLUS
  2347.         DW    HOLD,    SEMIS
  2348.  
  2349. ;=:   #S    process all significant digits of d1    d1 -- 0.
  2350.  
  2351.         $COLON    82H,#,S,DIGS
  2352. DIGS1:         DW    DIG
  2353.         DW    OVER,    OVER
  2354.         DW    ORR,    ZEQU
  2355.             $GO?0    DIGS1
  2356.         DW    SEMIS
  2357.  
  2358. ;=:   D.R    print d right-aligned in n columns    d n --
  2359.  
  2360.         $COLON    83H,D.,R,DDOTR
  2361.         DW    TOR,    SWAP,    OVER
  2362.         DW    DABS
  2363.         DW    BDIGS
  2364.         DW    DIGS,    SIGN
  2365.         DW    EDIGS
  2366.         DW    FROMR,    OVER,    SUBB
  2367.         DW    SPACS,    TYPES,    SEMIS
  2368.  
  2369. ;=:   .R    print n1 right-aligned in n2 columns    n1 n2 --
  2370.  
  2371.         $COLON    82H,.,R,DOTR
  2372.         DW    TOR
  2373.         DW    STOD,    FROMR,    DDOTR,    SEMIS
  2374.  
  2375. ;=:   D.    print a 32-bit number            d --
  2376.  
  2377.         $COLON    82H,D,.,DDOT
  2378.         DW    ZERO
  2379.         DW    DDOTR,    SPACE,    SEMIS
  2380.  
  2381. ;=:   .        print a 16-bit number            n --
  2382.  
  2383.         $COLON    81H,,.,DOT
  2384.         DW    STOD,    DDOT,    SEMIS
  2385.  
  2386. ;=:   ?        print the value at addr            addr --
  2387.  
  2388.         $COLON    81H,,?,QUES
  2389.         DW    AT,    DOT,    SEMIS
  2390.  
  2391. ;=:   U.    print an unsigned 16-bit number        u --
  2392.  
  2393.         $COLON    82H,U,.,UDOT
  2394.         DW    ZERO,    DDOT,    SEMIS
  2395.  
  2396. ;=:   VLIST    print the words in CONTEXT vocabulary    --
  2397.  
  2398.         $COLON    85H,VLIS,T
  2399.         DW    LIT,    80H
  2400.         DW    OUTT,    STORE
  2401.         DW    CONT,    AT,    AT
  2402. VLIS1:         DW    OUTT,    AT
  2403.         DW    CSLL,    GREAT
  2404.             $GO?0    VLIS2
  2405.         DW    CR
  2406.         DW    ZERO,    OUTT,    STORE
  2407. VLIS2:         DW    DUPP
  2408.         DW    IDDOT
  2409.         DW    SPACE,    SPACE
  2410.         DW    PFA,    LFA,    AT
  2411.         DW    DUPP,    ZEQU
  2412.         DW    QTERM,    ORR
  2413.             $GO?0    VLIS1
  2414.         DW    DROP,    SEMIS
  2415.  
  2416. ;=:   LIST    list screen n, as 16 lines of 64 chars    n --
  2417.  
  2418.         $COLON    84H,LIS,T,LISTC
  2419.         DW    DUPP,    BLOCK    ,DROP    ;added 7-9-83
  2420.         DW    DECA,    CR
  2421.         DW    DUPP,    SCR,    STORE
  2422.         DW    PDOTQ
  2423.         DB    6,"SCR # "
  2424.         DW    DOT
  2425.         DW    LIT,    16,    ZERO,    XDO
  2426. LIST1:         DW    CR,    IDO
  2427.         DW    LIT,    3,    DOTR,    SPACE
  2428.         DW    IDO,    SCR,    AT,    DLINE
  2429.         DW    QTERM
  2430.             $GO?0    LIST2
  2431.         DW    LEAVE
  2432. LIST2:             $LOOP    LIST1
  2433.         DW    CR,    SEMIS
  2434.  
  2435. ;=:   INDEX    print line 0 of screens n1 thru n2    n1 n2 --
  2436.  
  2437.         $COLON    85H,INDE,X
  2438.         DW    LIT,    FF,    EMIT,    CR
  2439.         DW    ONEP,    SWAP,    XDO
  2440. INDE1:         DW    CR,    IDO
  2441.         DW    LIT,    3,    DOTR,    SPACE
  2442.         DW    ZERO,    IDO,    DLINE
  2443.         DW    QTERM
  2444.             $GO?0    INDE2
  2445.         DW    LEAVE
  2446. INDE2:             $LOOP    INDE1
  2447.         DW    SEMIS
  2448.  
  2449. ;=:   TRIAD    list screens in groups of three        n1 n2 --
  2450.  
  2451.         $COLON    85H,TRIA,D
  2452.         DW    LIT,    FF,    EMIT
  2453.         DW    LIT,    3,    SLASH
  2454.         DW    LIT,    3,    STAR
  2455.         DW    LIT,    3,    OVER
  2456.         DW    PLUS,    SWAP,    XDO
  2457. TRIA1:         DW    CR,    IDO,    LISTC
  2458.         DW    QTERM
  2459.             $GO?0    TRIA2
  2460.         DW    LEAVE
  2461. TRIA2:             $LOOP    TRIA1
  2462.         DW    CR
  2463.         DW    LIT,    15,    MESS,    CR
  2464.         DW    SEMIS
  2465. ;
  2466.         $COLON    84H,.CP,U,DOTCPU
  2467.         DW    BASE,    AT
  2468.         DW    LIT,    36,    BASE,    STORE
  2469.         DW    LIT,    22H,    PORIG,    TAT
  2470.         DW    DDOT
  2471.         DW    BASE,    STORE,    SEMIS
  2472.  
  2473. IF    _EXTEND
  2474. INCLUDE    4TH-XTNS.ASM
  2475. ENDIF
  2476.  
  2477.     $REPORT    <FORTH definitions completed>
  2478.  
  2479. SUBTTL End of FORTH dictionary
  2480. PAGE
  2481.  
  2482.  
  2483.  
  2484. ;=:   TASK    word to mark the end of the dictionary    --
  2485.  
  2486. LASTNFA:
  2487.         $COLON    84H,TAS,K,TASK
  2488.         DW    SEMIS
  2489. ;
  2490. INITDP        EQU    $
  2491. MAIN        ENDS
  2492.  
  2493.     $REPORT    <End of assembly source>
  2494.  
  2495.         END    ORIG
  2496.